host: block editor — edit the :body composition (composition roadmap step 6)
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 /<cslug>/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 <noreply@anthropic.com>
This commit is contained in:
144
lib/host/blog.sx
144
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 /<cslug>/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 /<slug>/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 /<slug>/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))
|
||||
|
||||
@@ -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)"
|
||||
|
||||
@@ -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 `/<cslug>/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
|
||||
|
||||
Reference in New Issue
Block a user