diff --git a/lib/host/blog.sx b/lib/host/blog.sx index dce94ead..bb0fb268 100644 --- a/lib/host/blog.sx +++ b/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 ). 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