host: Part A — type-block GRAMMAR (a Composition field declares which blocks it permits)
The type now GOVERNS the composition, not just declares the slot. A Composition field carries
its grammar: {:name "body" :type "Composition" :blocks (…card types…) :allow ("cond" "each")}.
:blocks absent -> any card subtype (back-compat); :allow absent -> both control blocks.
- host/blog--{field-decl, allowed-blocks, allows-control?, block-allowed?, comp-violations}.
- The editor PALETTE is the grammar: one <option> per allowed card type (spliced as direct
<select> children), and the conditional/repeater add-forms appear only if :allow permits.
- block-add-submit ENFORCES it (was a coarse "any card subtype" check) — the type governs writes.
- comp-violations flags a composition holding a forbidden block (the save/import gate).
- article declares its :body grammar (all 7 card kinds + cond/each).
blog 179/179, full conformance 408/408 (+ grammar tests: allowed-blocks/allows-control?,
palette shows only permitted kinds, add rejects a forbidden card, violations flags one).
Part B (relations as type-governed composition) + Part C (edit the type definition) next.
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
112
lib/host/blog.sx
112
lib/host/blog.sx
@@ -494,6 +494,48 @@
|
||||
;; block editor instead of a text input).
|
||||
(define host/blog--scalar-fields
|
||||
(fn (slug) (filter (fn (f) (not (= (get f :type) "Composition"))) (host/blog--fields-for-post slug))))
|
||||
;; ── type-block GRAMMAR (layer 2b): a Composition field declares which block kinds it may
|
||||
;; contain. {:name "body" :type "Composition" :blocks (…card types…) :allow ("cond" "each")}.
|
||||
;; :blocks absent -> every card subtype (back-compat); :allow absent -> both control blocks. --
|
||||
(define host/blog--field-decl
|
||||
(fn (slug field)
|
||||
(let loop ((fs (host/blog--fields-for-post slug)))
|
||||
(cond ((empty? fs) nil)
|
||||
((= (str (get (first fs) :name)) field) (first fs))
|
||||
(else (loop (rest fs)))))))
|
||||
;; the card types a field permits (its :blocks, else all subtypes of "card").
|
||||
(define host/blog--allowed-blocks
|
||||
(fn (slug field)
|
||||
(let ((d (host/blog--field-decl slug field)))
|
||||
(if (and d (get d :blocks)) (get d :blocks) (host/blog--subtype-closure (list "card") :in)))))
|
||||
;; whether a control block ("cond"/"each") is permitted in a field (its :allow, else both).
|
||||
(define host/blog--allows-control?
|
||||
(fn (slug field kind)
|
||||
(let ((d (host/blog--field-decl slug field)))
|
||||
(if (and d (get d :allow)) (contains? (get d :allow) kind) true))))
|
||||
;; whether a specific card type may be added to a field (grammar check for the add handler).
|
||||
(define host/blog--block-allowed?
|
||||
(fn (slug field ctype) (contains? (host/blog--allowed-blocks slug field) ctype)))
|
||||
;; a short editor label for a card type: strip the "card-" prefix.
|
||||
(define host/blog--card-label
|
||||
(fn (ct) (if (starts-with? ct "card-") (substr ct 5) ct)))
|
||||
;; grammar violations of a field's current composition (empty = valid): card nodes whose type
|
||||
;; isn't permitted, control blocks that aren't allowed. Used on save/import.
|
||||
(define host/blog--comp-violations
|
||||
(fn (slug field)
|
||||
(reduce
|
||||
(fn (acc node)
|
||||
(let ((k (host/blog--node-kind node)))
|
||||
(cond
|
||||
((= k "card")
|
||||
(let ((ct (host/blog--primary-card-type (host/blog--resolve-ref (str (first (rest node))) {"container" slug}))))
|
||||
(if (host/blog--block-allowed? slug field ct) acc
|
||||
(concat acc (list (str "block ‘" ct "’ is not allowed in :" field))))))
|
||||
((or (= k "cond") (= k "each"))
|
||||
(if (host/blog--allows-control? slug field k) acc
|
||||
(concat acc (list (str "‘" k "’ blocks are not allowed in :" field)))))
|
||||
(else acc))))
|
||||
(list) (host/blog--comp-nodes slug field))))
|
||||
;; render one labelled input per field, pre-filled from `values`. Widget per value-type
|
||||
;; (textarea for Text, else a typed <input>). Pure — takes pre-fetched fields + values.
|
||||
(define host/blog--field-inputs
|
||||
@@ -1158,10 +1200,12 @@
|
||||
(host/blog--set-fields! "article"
|
||||
(list {:name "subtitle" :type "String"}
|
||||
{:name "hero" :type "URL"}
|
||||
;; :body is a COMPOSITION field (layer 2) — an article's body is a composition of
|
||||
;; cards, edited by the block editor and rendered by the fold. Declaring it here
|
||||
;; makes the structure explicit (the default would also yield ["body"]).
|
||||
{:name "body" :type "Composition"}))
|
||||
;; :body is a COMPOSITION field (layer 2) whose GRAMMAR (layer 2b) the type
|
||||
;; declares: :blocks = the card kinds an article body may contain, :allow = the
|
||||
;; control blocks permitted. The editor palette + save/import validation read this.
|
||||
{:name "body" :type "Composition"
|
||||
:blocks (list "card-heading" "card-text" "card-image" "card-quote" "card-embed" "card-code" "card-callout")
|
||||
:allow (list "cond" "each")}))
|
||||
;; article's render TEMPLATE (Slice 8c) — the subtitle field shown as a standfirst
|
||||
;; above the body. (field "subtitle") resolves to the instance's value at render.
|
||||
(host/blog--set-template! "article"
|
||||
@@ -1700,38 +1744,45 @@
|
||||
;; one per field the object's type declares (layer 2).
|
||||
(define host/blog--block-editor
|
||||
(fn (slug field)
|
||||
(let ((nodes (host/blog--comp-nodes slug field)))
|
||||
(let ((rows (map-indexed (fn (i n) (host/blog--block-row slug field i n)) nodes)))
|
||||
(let ((nodes (host/blog--comp-nodes slug field))
|
||||
(allowed (host/blog--allowed-blocks slug field)))
|
||||
(let ((rows (map-indexed (fn (i n) (host/blog--block-row slug field i n)) nodes))
|
||||
;; the CARD PALETTE is the field's grammar (:blocks) — one <option> per allowed
|
||||
;; card type, spliced as DIRECT <select> children (a wrapper breaks a boosted swap).
|
||||
(card-opts (map (fn (ct) (quasiquote (option :value (unquote ct) (unquote (host/blog--card-label ct))))) allowed))
|
||||
;; control-block add-forms only appear if the grammar permits them (:allow).
|
||||
(add-cond
|
||||
(if (host/blog--allows-control? slug field "cond")
|
||||
(quasiquote (form :method "post" :action (unquote (str "/" slug "/blocks/add-cond"))
|
||||
:sx-post (unquote (str "/" slug "/blocks/add-cond")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
|
||||
:style "margin-top:0.3em"
|
||||
(unquote (host/blog--fld field))
|
||||
(select :name "cond"
|
||||
(option :value "auth" "logged in") (option :value "device:mobile" "on mobile")
|
||||
(option :value "device:desktop" "on desktop") (option :value "locale:fr" "locale = fr"))
|
||||
" " (button :type "submit" "+ conditional (or)")))
|
||||
""))
|
||||
(add-each
|
||||
(if (host/blog--allows-control? slug field "each")
|
||||
(quasiquote (form :method "post" :action (unquote (str "/" slug "/blocks/add-each"))
|
||||
:sx-post (unquote (str "/" slug "/blocks/add-each")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
|
||||
:style "margin-top:0.3em"
|
||||
(unquote (host/blog--fld field))
|
||||
(input :name "type" :placeholder "type name (e.g. compose-item)" :style "width:40%")
|
||||
" " (button :type "submit" "+ repeater (each)")))
|
||||
"")))
|
||||
(quasiquote
|
||||
(div :id (unquote (str "comp-" field)) :style "margin-top:1.5em;border-top:1px solid #ccc;padding-top:1em"
|
||||
(h3 :style "font-size:1em;margin:0 0 0.3em" (unquote (str ":" field " (composition)")))
|
||||
(unquote (if (> (len nodes) 0) (cons (quote ul) rows) (quote (p :style "color:#999" "No blocks yet."))))
|
||||
;; add a CARD block. Options are DIRECT <select> children.
|
||||
(form :method "post" :action (unquote (str "/" slug "/blocks/add"))
|
||||
:sx-post (unquote (str "/" slug "/blocks/add")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
|
||||
(unquote (host/blog--fld field))
|
||||
(select :name "ctype"
|
||||
(option :value "card-heading" "heading") (option :value "card-text" "text")
|
||||
(option :value "card-quote" "quote") (option :value "card-code" "code")
|
||||
(option :value "card-callout" "callout"))
|
||||
(unquote (cons (quote select) (append (quasiquote (:name "ctype")) card-opts)))
|
||||
" " (input :name "text" :placeholder "text…" :style "width:40%")
|
||||
" " (button :type "submit" "+ card"))
|
||||
;; add a CONDITIONAL (or) block.
|
||||
(form :method "post" :action (unquote (str "/" slug "/blocks/add-cond"))
|
||||
:sx-post (unquote (str "/" slug "/blocks/add-cond")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
|
||||
:style "margin-top:0.3em"
|
||||
(unquote (host/blog--fld field))
|
||||
(select :name "cond"
|
||||
(option :value "auth" "logged in") (option :value "device:mobile" "on mobile")
|
||||
(option :value "device:desktop" "on desktop") (option :value "locale:fr" "locale = fr"))
|
||||
" " (button :type "submit" "+ conditional (or)"))
|
||||
;; add a REPEATER (each) block.
|
||||
(form :method "post" :action (unquote (str "/" slug "/blocks/add-each"))
|
||||
:sx-post (unquote (str "/" slug "/blocks/add-each")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
|
||||
:style "margin-top:0.3em"
|
||||
(unquote (host/blog--fld field))
|
||||
(input :name "type" :placeholder "type name (e.g. compose-item)" :style "width:40%")
|
||||
" " (button :type "submit" "+ repeater (each)"))))))))
|
||||
(unquote add-cond)
|
||||
(unquote add-each)))))))
|
||||
;; the edit page's composition section (#block-editor): one block editor per composition
|
||||
;; field the type declares (layer 2 — types define the object's structure).
|
||||
(define host/blog--block-editors
|
||||
@@ -2144,10 +2195,9 @@
|
||||
(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))
|
||||
;; the ctype must be PERMITTED by the field's grammar (:blocks the type declares —
|
||||
;; default: any card subtype). This is where the type governs the composition.
|
||||
(when (and (host/blog-exists? slug) (host/blog--block-allowed? slug field ctype))
|
||||
(host/blog-block-add! slug field ctype
|
||||
(if (= ctype "card-heading") {"level" "2" "text" text} {"text" text})))
|
||||
(host/blog--block-resp req slug field)))))
|
||||
|
||||
@@ -934,6 +934,43 @@
|
||||
(host-bl-test "composition-fields defaults to [body] when the type declares none"
|
||||
(begin (host/blog-put! "plain1" "P" "(p)" "published") (host/blog--composition-fields "plain1"))
|
||||
(list "body"))
|
||||
;; -- LAYER 2b: type-block GRAMMAR — a Composition field declares which block kinds it PERMITS.
|
||||
;; The type governs the composition: editor palette + add + validation all read the grammar. --
|
||||
(host-bl-test "allowed-blocks + allows-control? read the field's grammar (:blocks / :allow)"
|
||||
(begin
|
||||
(host/blog-seed! "grmtype" "G" "(p)" "published")
|
||||
(host/blog-relate! "grmtype" "type" "subtype-of")
|
||||
(host/blog--set-fields! "grmtype"
|
||||
(list {:name "body" :type "Composition" :blocks (list "card-text" "card-heading") :allow (list "cond")}))
|
||||
(host/blog-put! "grm1" "G1" "(article)" "published")
|
||||
(host/blog-relate! "grm1" "grmtype" "is-a")
|
||||
(list (host/blog--allowed-blocks "grm1" "body")
|
||||
(host/blog--block-allowed? "grm1" "body" "card-text") (host/blog--block-allowed? "grm1" "body" "card-image")
|
||||
(host/blog--allows-control? "grm1" "body" "cond") (host/blog--allows-control? "grm1" "body" "each")))
|
||||
(list (list "card-text" "card-heading") true false true false))
|
||||
;; the editor PALETTE is the grammar — only the allowed card types + permitted control blocks.
|
||||
(host-bl-test "the block editor palette shows only the grammar's card kinds + allowed controls"
|
||||
(let ((html (render-page (host/blog--block-editor "grm1" "body"))))
|
||||
(list (contains? html "value=\"card-text\"") (contains? html "value=\"card-heading\"")
|
||||
(contains? html "value=\"card-image\"") (contains? html "+ conditional") (contains? html "+ repeater")))
|
||||
(list true true false true false))
|
||||
;; the add handler REJECTS a card kind outside the grammar (the type governs writes).
|
||||
(host-bl-test "block-add-submit rejects a card kind the grammar forbids"
|
||||
(begin
|
||||
(host/blog--set-body! "grm1" (quote (seq)))
|
||||
(host-bl-wapp (host-bl-send "POST" "/grm1/blocks/add" "Bearer good"
|
||||
"application/x-www-form-urlencoded" "field=body&ctype=card-image&text=x"))
|
||||
(list (len (host/blog--comp-nodes "grm1" "body")) ;; image rejected -> 0
|
||||
(begin (host-bl-wapp (host-bl-send "POST" "/grm1/blocks/add" "Bearer good"
|
||||
"application/x-www-form-urlencoded" "field=body&ctype=card-text&text=ok"))
|
||||
(len (host/blog--comp-nodes "grm1" "body"))))) ;; text allowed -> 1
|
||||
(list 0 1))
|
||||
;; validation flags a composition holding a block the grammar forbids (import/save gate).
|
||||
(host-bl-test "comp-violations flags a card kind outside the field's grammar"
|
||||
(begin
|
||||
(host/blog-block-add! "grm1" "body" "card-image" {"src" "x.jpg"}) ;; model add bypasses the handler guard
|
||||
(> (len (host/blog--comp-violations "grm1" "body")) 0))
|
||||
true)
|
||||
;; the editor renders a HAND-AUTHORED composition (text/row/alt-with-text) WITHOUT falling
|
||||
;; through to "(unknown block)" — every node kind gets a labelled row (the compose-demo case).
|
||||
(host-bl-test "the block editor renders text/layout/inline-alt nodes (no unknown block)"
|
||||
|
||||
Reference in New Issue
Block a user