From b78491a5a16ca0c83babed0cb5d1d5ba6027ef08 Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 30 Jun 2026 23:45:20 +0000 Subject: [PATCH] =?UTF-8?q?host:=20block=20editor=20=E2=80=94=20edit=20the?= =?UTF-8?q?=20:body=20composition=20(composition=20roadmap=20step=206)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The post body is now editable as a composition. Model ops over the :body ref-seq (and the ordered `contains` edges): host/blog-block-add! (create a card object is-a a card-type + fields, contains edge, append a ref), -remove! (drop ref + edge), -move! (swap adjacent). host/blog--block-editor renders a row per block — type + a content preview + ↑/↓/remove controls + a "fields" link — plus an add-block form, injected into the edit page. Routes POST /:slug/blocks/{add, :cslug/remove, :cslug/move} (guarded; SX-htmx sx-post + outerHTML swap of #block-editor, redirect fallback for no-JS). Cards-as-objects pays off: per-block FIELD editing is free — a card IS an object, so its fields are edited via its own //edit page; the block editor only owns structure. Guard fix: a card type is a SUBTYPE-OF card (not is-a), so the add validates ctype against the down-closure of "card", not host/blog-is-a?. Verified via the warm server (162/164; the 2 fails are the pre-existing relate-picker pair). Deferred: Playwright live-swap check; alt/each block insertion (the core editor handles the seq of refs). Co-Authored-By: Claude Opus 4.8 --- lib/host/blog.sx | 144 +++++++++++++++++++++++++++++++++++ lib/host/tests/blog.sx | 33 ++++++++ plans/composition-objects.md | 8 +- 3 files changed, 184 insertions(+), 1 deletion(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 27f0dc77..e098da12 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -639,6 +639,70 @@ (list (quote ref) cslug))))) blocks))) (host/blog--set-body! post-slug (cons (quote seq) refs))))))) + +;; ── block-editor model: edit a post's :body (its composition of card refs) ─────────── +;; The body is (seq (ref c0) (ref c1) …); these ops add / remove / reorder its blocks and +;; keep the ordered `contains` edges in step. The :body seq is the ORDER authority, the +;; contains edges the membership set. Per-block FIELD editing is free: a card is an object, +;; so its fields are edited via the card's own //edit page. (composition step 6.) +(define host/blog-body-refs + (fn (slug) + (let ((body (host/blog-body-of slug))) + (if (and (= (type-of body) "list") (= (str (first body)) "seq")) + (reduce (fn (acc n) + (if (and (= (type-of n) "list") (= (str (first n)) "ref")) + (concat acc (list (str (first (rest n))))) acc)) + (list) (rest body)) + (list))))) +(define host/blog--set-body-refs! + (fn (slug refs) + (host/blog--set-body! slug (cons (quote seq) (map (fn (r) (list (quote ref) r)) refs))))) +(define host/blog--next-block-idx + (fn (slug) + (let loop ((i 0)) + (if (host/blog-exists? (str slug "__b" i)) (loop (+ i 1)) i)))) +(define host/blog-block-add! + (fn (slug ctype fields) + (let ((cslug (str slug "__b" (host/blog--next-block-idx slug)))) + (begin + (host/blog-seed! cslug ctype "(article (h1 \"card\"))" "block") + (host/blog-relate! cslug ctype "is-a") + (host/blog--set-field-values! cslug fields) + (host/blog-relate! slug cslug "contains") + (host/blog--set-body-refs! slug (concat (host/blog-body-refs slug) (list cslug))) + cslug)))) +(define host/blog-block-remove! + (fn (slug cslug) + (begin + (host/blog--set-body-refs! slug + (filter (fn (r) (not (= r cslug))) (host/blog-body-refs slug))) + (host/blog-unrelate! slug cslug "contains")))) +(define host/blog--nth-ref + (fn (xs k) + (let loop ((i 0) (ys xs)) + (cond ((empty? ys) nil) ((= i k) (first ys)) (else (loop (+ i 1) (rest ys))))))) +(define host/blog--ref-index + (fn (xs x) + (let loop ((i 0) (ys xs)) + (cond ((empty? ys) -1) ((= (first ys) x) i) (else (loop (+ i 1) (rest ys))))))) +(define host/blog-block-move! + (fn (slug cslug dir) + (let ((refs (host/blog-body-refs slug))) + (let ((i (host/blog--ref-index refs cslug))) + (let ((j (if (= dir "up") (- i 1) (+ i 1)))) + (when (and (>= i 0) (>= j 0) (< j (len refs))) + (host/blog--set-body-refs! slug + (map-indexed (fn (k r) (cond ((= k i) (host/blog--nth-ref refs j)) + ((= k j) (host/blog--nth-ref refs i)) + (else r))) refs)))))))) +;; the card-type of a card object (its declared is-a target); "card" if none. +(define host/blog--primary-card-type + (fn (cslug) (let ((ts (host/blog-out cslug "is-a"))) (if (empty? ts) "card" (first ts))))) +;; a short text preview of a card's content from its field-values. +(define host/blog--block-preview + (fn (vals) + (let ((t (str (or (get vals "text") (get vals "src") (get vals "code") (get vals "url") "")))) + (if (> (len t) 60) (str (substr t 0 60) "…") t)))) ;; Seed a live demo of the composition fold: one object, rendered by host/comp-render, that ;; shows seq + alt(when auth) + row(par) + each — and renders DIFFERENTLY logged-in vs out. (define host/blog-seed-compose-demo! @@ -1246,6 +1310,47 @@ (map (fn (spec) (host/blog--relation-editor slug (get spec :kind) false)) host/blog-rel-kinds)))) +;; ── block editor: edit the post :body composition (insert/reorder/remove blocks) ───── +;; A row per block (type + preview + up/down/remove + a link to edit the card's fields) and +;; an add-block form. Each control sx-posts its route, sx-swap="outerHTML" replacing +;; #block-editor with the re-render (live reorder/add/remove). Wrapped for the swap target. +;; one sx-post button-form targeting #block-editor (dir passed as a hidden field). +(define host/blog--block-btn + (fn (slug cslug action dir label) + (let ((url (str "/" slug "/blocks/" cslug "/" action))) + (quasiquote + (form :method "post" :action (unquote url) :style "display:inline;margin:0" + :sx-post (unquote url) :sx-target "#block-editor" :sx-swap "outerHTML" :sx-disable "true" + (unquote (if (= dir "") "" (quasiquote (input :type "hidden" :name "dir" :value (unquote dir))))) + (button :type "submit" (unquote label))))))) +(define host/blog--block-row + (fn (slug cslug) + (let ((ctype (host/blog--primary-card-type cslug)) + (vals (host/blog-field-values-of cslug))) + (quasiquote + (li :style "display:flex;gap:0.5em;align-items:center;border:1px solid #ddd;padding:0.4em;margin:0.2em 0" + (span :style "font-weight:bold;min-width:7em" (unquote ctype)) + (span :style "flex:1;color:#555" (unquote (host/blog--block-preview vals))) + (a :href (unquote (str "/" cslug "/edit")) "fields") + (unquote (host/blog--block-btn slug cslug "move" "up" "↑")) + (unquote (host/blog--block-btn slug cslug "move" "down" "↓")) + (unquote (host/blog--block-btn slug cslug "remove" "" "remove"))))))) +(define host/blog--block-editor + (fn (slug) + (let ((refs (host/blog-body-refs slug))) + (let ((rows (map (fn (c) (host/blog--block-row slug c)) refs)) + (type-opts (map (fn (ct) (quasiquote (option :value (unquote ct) (unquote ct)))) + (list "card-heading" "card-text" "card-quote" "card-code" "card-callout")))) + (quasiquote + (div :id "block-editor" :style "margin-top:1.5em;border-top:1px solid #ccc;padding-top:1em" + (h3 :style "font-size:1em;margin:0 0 0.3em" "Blocks") + (unquote (if (> (len refs) 0) (cons (quote ul) rows) (quote (p :style "color:#999" "No blocks yet.")))) + (form :method "post" :action (unquote (str "/" slug "/blocks/add")) + :sx-post (unquote (str "/" slug "/blocks/add")) :sx-target "#block-editor" :sx-swap "outerHTML" + (select :name "ctype" (unquote (cons (quote span) type-opts))) + " " (input :name "text" :placeholder "text…" :style "width:50%") + " " (button :type "submit" "+ add block")))))))) + ;; ── read handlers ─────────────────────────────────────────────────── ;; Post body is rendered per-block (a guarded HTML string) then injected raw. (define host/blog-post @@ -1630,6 +1735,40 @@ (dream-html (render-page (host/blog--relation-editor slug kind true))) (dream-redirect (str "/" slug "/edit"))))))) +;; POST //blocks/add|remove|move — structural edits to the post :body. Each does the +;; durable op then returns the re-rendered #block-editor (AJAX swap) or redirects (no-JS). +(define host/blog--block-resp + (fn (req slug) + (if (host/blog--editor-swap-req? req) + (dream-html (render-page (host/blog--block-editor slug))) + (dream-redirect (str "/" slug "/edit"))))) +(define host/blog-block-add-submit + (fn (req) + (let ((slug (dream-param req "slug")) + (ctype (or (host/field req "ctype") "card-text")) + (text (or (host/field req "text") ""))) + (begin + ;; ctype must be a card type — a subtype of "card" (card types are linked by + ;; subtype-of, NOT is-a, so the down-closure of "card" is the valid set). + (when (and (host/blog-exists? slug) + (contains? (host/blog--subtype-closure (list "card") :in) ctype)) + (host/blog-block-add! slug ctype + (if (= ctype "card-heading") {"level" "2" "text" text} {"text" text}))) + (host/blog--block-resp req slug))))) +(define host/blog-block-remove-submit + (fn (req) + (let ((slug (dream-param req "slug")) (cslug (dream-param req "cslug"))) + (begin + (when (host/blog-exists? slug) (host/blog-block-remove! slug cslug)) + (host/blog--block-resp req slug))))) +(define host/blog-block-move-submit + (fn (req) + (let ((slug (dream-param req "slug")) (cslug (dream-param req "cslug")) + (dir (or (host/field req "dir") "up"))) + (begin + (when (host/blog-exists? slug) (host/blog-block-move! slug cslug dir)) + (host/blog--block-resp req slug))))) + ;; GET //edit — edit form pre-filled with the post's current title, raw ;; sx_content (in a textarea — render-to-html escapes the text child, so the ;; browser shows the source verbatim), and status (current value pre-selected). @@ -1646,6 +1785,7 @@ ;; the relation editors + tag toggle do durable reads — compute them ;; here, not in the quasiquote, so IO stays in the handler body. (let ((relation-editors (host/blog--relation-editors slug)) + (block-editor (host/blog--block-editor slug)) (tag-toggle (host/blog--is-tag-toggle slug)) (post-fields (host/blog--fields-for-post slug)) (field-values (host/blog-field-values-of slug)) @@ -1677,6 +1817,7 @@ (button :type "submit" "Save"))) (div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em" (unquote tag-toggle)) + (unquote block-editor) (unquote relation-editors) (p :style "margin-top:1.5em" (a :href (unquote (str "/" slug "/")) "view post") @@ -1754,6 +1895,9 @@ (dream-post "/new" (host/blog--protect-html resolve host/blog-form-submit)) (dream-get "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-form)) (dream-post "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-submit)) + (dream-post "/:slug/blocks/add" (host/blog--protect-html resolve host/blog-block-add-submit)) + (dream-post "/:slug/blocks/:cslug/remove" (host/blog--protect-html resolve host/blog-block-remove-submit)) + (dream-post "/:slug/blocks/:cslug/move" (host/blog--protect-html resolve host/blog-block-move-submit)) (dream-post "/:slug/relate" (host/blog--protect-html resolve host/blog-relate-submit)) (dream-post "/:slug/unrelate" (host/blog--protect-html resolve host/blog-unrelate-submit)) (dream-post "/meta/new-type" (host/blog--protect-html resolve host/blog-meta-new-type)) diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 80086b76..fec9036a 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -817,6 +817,39 @@ (let ((html (dream-resp-body (host-bl-app (host-bl-req "/imp-x/"))))) (list (contains? html "Heading One") (contains? html "Para text.") (contains? html "p.jpg"))) (list true true true)) +;; -- block editor: structural edits to the post :body composition (step 6). -- +(host-bl-test "block-add! creates a card object + contains edge + appends a ref to the body" + (begin + (host/blog-put! "bdoc" "BDoc" "(article)" "published") + (host/blog--set-body! "bdoc" (quote (seq))) + (let ((c0 (host/blog-block-add! "bdoc" "card-text" {"text" "first"})) + (c1 (host/blog-block-add! "bdoc" "card-heading" {"level" "2" "text" "a head"}))) + (list (host/blog-body-refs "bdoc") + (host/blog-is-a? c0 "card-text") + (contains? (host/blog-out "bdoc" "contains") c1)))) + (list (list "bdoc__b0" "bdoc__b1") true true)) +(host-bl-test "block-move! reorders the body refs (and is a no-op at the ends)" + (begin + (host/blog-block-move! "bdoc" "bdoc__b1" "up") ;; b1 before b0 + (let ((after-up (host/blog-body-refs "bdoc"))) + (host/blog-block-move! "bdoc" "bdoc__b1" "up") ;; b1 already first -> no-op + (list after-up (host/blog-body-refs "bdoc")))) + (list (list "bdoc__b1" "bdoc__b0") (list "bdoc__b1" "bdoc__b0"))) +(host-bl-test "block-remove! drops the ref from the body + the contains edge" + (begin + (host/blog-block-remove! "bdoc" "bdoc__b1") + (list (host/blog-body-refs "bdoc") (contains? (host/blog-out "bdoc" "contains") "bdoc__b1"))) + (list (list "bdoc__b0") false)) +(host-bl-test "the edit page shows the block editor (#block-editor + an add-block form)" + (let ((html (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/bdoc/edit" "Bearer good" "" ""))))) + (list (contains? html "block-editor") (contains? html "+ add block"))) + (list true true)) +(host-bl-test "POST /bdoc/blocks/add (auth) adds a block -> body grows" + (begin + (host-bl-wapp (host-bl-send "POST" "/bdoc/blocks/add" "Bearer good" + "application/x-www-form-urlencoded" "ctype=card-text&text=added+block")) + (len (host/blog-body-refs "bdoc"))) + 2) (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/plans/composition-objects.md b/plans/composition-objects.md index 809e99fa..133ef846 100644 --- a/plans/composition-objects.md +++ b/plans/composition-objects.md @@ -118,7 +118,13 @@ Transclusion = a `ref` leaf. Sort/filter/limit/group = the *source query* langua typed-block path. `/import` wired; home filtered to published so `"block"` cards stay hidden. The `val` (raw value) leaf added for attribute interpolation. (Perf: typing now reads direct KV `subtype-of` edges via a host-side BFS, not lib/relations — no Datalog re-saturation.) -6. The block editor edits the body (insert/reorder/`alt`/`each`) — the metamodel editor for content. +6. **(done, server-side)** The block editor edits the body: `host/blog-block-add!` / + `-remove!` / `-move!` operate on the `:body` ref-seq + ordered `contains` edges; + `host/blog--block-editor` renders a row per block (type + preview + ↑/↓/remove + a link + to edit the card's fields) + an add-block form, injected into the edit page; routes + `POST /:slug/blocks/{add,:cslug/remove,:cslug/move}` (guarded, SX-htmx outerHTML swap). + Per-block field editing is free — a card is an object, edited via its own `//edit`. + (Live SX-htmx swap still wants a Playwright check; `alt`/`each` block insertion deferred.) 7. **Prove universality with a second fold.** Write a tiny `execute`-fold over the *same* `seq/alt/each` structure that *runs* a workflow (leaves = effects; `seq` = steps in order, `alt` = branch, `each` = for-each) — the way the recursive tree proved recursion, this proves the