host: Part C — edit the TYPE DEFINITION (its grammar) on the type's own page
"It's just more composition": a type post's edit page now shows a Type-definition editor —
each field as name:type, and each Composition field with a GRAMMAR CHECKLIST (a checkbox per
card kind = permitted, + conditional/repeater toggles). Editing it changes what the type's
instances may contain. host/blog--{is-type?, set-field-grammar!, own-field, checkbox,
grammar-form, type-def-editor}; POST /<type>/grammar reads the checklist (uniquely-named
blk-<ct> / allow-<ctrl> boxes, since form fields are single-value) → set-field-grammar!.
Shown only when host/blog--is-type? (declares fields, or subtype-of type) — a type's page has
it, an instance's doesn't.
blog 184/184, full conformance 413/413 (+ Part C tests: is-type?, set-field-grammar!, the
checklist renders, POST /grammar sets it, appears on a type page not an instance's).
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
@@ -536,6 +536,28 @@
|
||||
(concat acc (list (str "‘" k "’ blocks are not allowed in :" field)))))
|
||||
(else acc))))
|
||||
(list) (host/blog--comp-nodes slug field))))
|
||||
;; ── Part C: the TYPE DEFINITION is itself editable — a type's :fields (each with, for a
|
||||
;; Composition field, its block grammar) are displayed + edited on the type's own edit page.
|
||||
;; is this post a TYPE? (declares fields, or is subtype-of "type" transitively). --
|
||||
(define host/blog--is-type?
|
||||
(fn (slug)
|
||||
(or (> (len (host/blog-fields-of slug)) 0)
|
||||
(contains? (host/blog--subtype-closure (host/blog-out slug "subtype-of") :out) "type"))))
|
||||
;; set a Composition field's grammar (:blocks + :allow) on a type, preserving its other fields.
|
||||
(define host/blog--set-field-grammar!
|
||||
(fn (slug fname blocks allow)
|
||||
(host/blog--set-fields! slug
|
||||
(map (fn (f) (if (= (str (get f :name)) fname) (merge f {:blocks blocks :allow allow}) f))
|
||||
(host/blog-fields-of slug)))))
|
||||
;; a labelled checkbox (the attr must be OMITTED when unchecked — an empty :checked still
|
||||
;; checks the box).
|
||||
(define host/blog--checkbox
|
||||
(fn (name label checked)
|
||||
(if checked
|
||||
(quasiquote (label :style "margin-right:0.9em;white-space:nowrap"
|
||||
(input :type "checkbox" :name (unquote name) :checked "checked") " " (unquote label)))
|
||||
(quasiquote (label :style "margin-right:0.9em;white-space:nowrap"
|
||||
(input :type "checkbox" :name (unquote name)) " " (unquote label))))))
|
||||
;; 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
|
||||
@@ -1792,6 +1814,56 @@
|
||||
(unquote (cons (quote div)
|
||||
(map (fn (f) (host/blog--block-editor slug f)) (host/blog--composition-fields slug))))))))
|
||||
|
||||
;; ── Part C: the TYPE-DEFINITION editor (shown when editing a TYPE post). "It's just more
|
||||
;; composition" — a type's :fields are displayed, and each Composition field's grammar (which
|
||||
;; card kinds + control blocks it permits) is edited with a checklist. The type governs what
|
||||
;; its instances' compositions can contain; here you edit that governance. --
|
||||
(define host/blog--own-field
|
||||
(fn (slug fname)
|
||||
(let loop ((fs (host/blog-fields-of slug)))
|
||||
(cond ((empty? fs) nil) ((= (str (get (first fs) :name)) fname) (first fs)) (else (loop (rest fs)))))))
|
||||
;; the grammar edit form for ONE Composition field (id #grammar-<field>): a checkbox per card
|
||||
;; type (checked = permitted) + conditional/repeater toggles, POSTing to /<slug>/grammar.
|
||||
(define host/blog--grammar-form
|
||||
(fn (slug fdecl)
|
||||
(let ((fname (str (get fdecl :name)))
|
||||
(cur (or (get fdecl :blocks) (host/blog--subtype-closure (list "card") :in)))
|
||||
(ctrl (or (get fdecl :allow) (list "cond" "each")))
|
||||
(all-cards (host/blog--subtype-closure (list "card") :in))
|
||||
(url (str "/" slug "/grammar")))
|
||||
(let ((tgt (str "#grammar-" fname))
|
||||
(card-checks (map (fn (ct) (host/blog--checkbox (str "blk-" ct) (host/blog--card-label ct) (contains? cur ct))) all-cards)))
|
||||
(cons (quote form)
|
||||
(append
|
||||
(quasiquote (:method "post" :action (unquote url) :sx-post (unquote url)
|
||||
:sx-target (unquote tgt) :sx-swap "outerHTML"
|
||||
:id (unquote (str "grammar-" fname))
|
||||
:style "margin:0.3em 0;padding:0.5em;border:1px dashed #bbb"
|
||||
(input :type "hidden" :name "field" :value (unquote fname))
|
||||
(div :style "font-weight:bold;font-size:0.9em;margin-bottom:0.3em"
|
||||
(unquote (str ":" fname " may contain these blocks —")))))
|
||||
(append card-checks
|
||||
(quasiquote ((br)
|
||||
(unquote (host/blog--checkbox "allow-cond" "conditional (or)" (contains? ctrl "cond")))
|
||||
(unquote (host/blog--checkbox "allow-each" "repeater (each)" (contains? ctrl "each")))
|
||||
(br) (button :type "submit" :style "margin-top:0.4em" "save grammar"))))))))))
|
||||
;; the whole type-definition editor: a row per field (scalar shown as name:type; Composition
|
||||
;; shown with its grammar form).
|
||||
(define host/blog--type-def-editor
|
||||
(fn (slug)
|
||||
(let ((fields (host/blog-fields-of slug)))
|
||||
(let ((rows (map (fn (f)
|
||||
(if (= (get f :type) "Composition")
|
||||
(host/blog--grammar-form slug f)
|
||||
(quasiquote (div :style "padding:0.15em 0;color:#555"
|
||||
(b (unquote (str (get f :name)))) (unquote (str " : " (get f :type)))))))
|
||||
fields)))
|
||||
(cons (quote div)
|
||||
(append
|
||||
(quasiquote (:id "type-def" :style "margin-top:1.5em;border-top:2px solid #999;padding-top:1em"
|
||||
(h3 :style "font-size:1em;margin:0 0 0.4em" "Type definition — what this type's instances may contain")))
|
||||
rows))))))
|
||||
|
||||
;; ── read handlers ───────────────────────────────────────────────────
|
||||
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
|
||||
(define host/blog-post
|
||||
@@ -2226,6 +2298,20 @@
|
||||
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (ckey (or (host/field req "cond") "auth")))
|
||||
(begin (when (host/blog-exists? slug) (host/blog-block-set-cond! slug field (host/blog--block-idx req) ckey))
|
||||
(host/blog--block-resp req slug field)))))
|
||||
;; POST /<type>/grammar — set a Composition field's block grammar from the checklist. Only on a
|
||||
;; TYPE post (it defines what its instances' compositions may contain).
|
||||
(define host/blog-grammar-submit
|
||||
(fn (req)
|
||||
(let ((slug (dream-param req "slug")) (fname (or (host/field req "field") "body")))
|
||||
(begin
|
||||
(when (and (host/blog-exists? slug) (host/blog--is-type? slug))
|
||||
(let ((all-cards (host/blog--subtype-closure (list "card") :in)))
|
||||
(host/blog--set-field-grammar! slug fname
|
||||
(filter (fn (ct) (not (nil? (host/field req (str "blk-" ct))))) all-cards)
|
||||
(filter (fn (c) (not (nil? (host/field req (str "allow-" c))))) (list "cond" "each")))))
|
||||
(if (host/blog--editor-swap-req? req)
|
||||
(dream-html (render-page (host/blog--grammar-form slug (host/blog--own-field slug fname))))
|
||||
(dream-redirect (str "/" slug "/edit")))))))
|
||||
|
||||
;; 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
|
||||
@@ -2244,6 +2330,8 @@
|
||||
;; 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-editors slug))
|
||||
;; if this post is a TYPE, its definition (fields + grammar) is editable here.
|
||||
(type-def (if (host/blog--is-type? slug) (host/blog--type-def-editor slug) ""))
|
||||
(tag-toggle (host/blog--is-tag-toggle slug))
|
||||
(post-fields (host/blog--scalar-fields slug))
|
||||
(field-values (host/blog-field-values-of slug))
|
||||
@@ -2275,6 +2363,7 @@
|
||||
(button :type "submit" "Save")))
|
||||
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
|
||||
(unquote tag-toggle))
|
||||
(unquote type-def)
|
||||
(unquote block-editor)
|
||||
(unquote relation-editors)
|
||||
(p :style "margin-top:1.5em"
|
||||
@@ -2360,6 +2449,7 @@
|
||||
(dream-post "/:slug/blocks/:idx/remove" (host/blog--protect-html resolve host/blog-block-remove-submit))
|
||||
(dream-post "/:slug/blocks/:idx/move" (host/blog--protect-html resolve host/blog-block-move-submit))
|
||||
(dream-post "/:slug/blocks/:idx/cond" (host/blog--protect-html resolve host/blog-block-cond-submit))
|
||||
(dream-post "/:slug/grammar" (host/blog--protect-html resolve host/blog-grammar-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))
|
||||
|
||||
@@ -971,6 +971,41 @@
|
||||
(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)
|
||||
;; -- Part C: the TYPE DEFINITION is itself displayed + edited (as composition) on the type's
|
||||
;; own edit page. is-type? gates it; the grammar checklist edits what instances may contain. --
|
||||
(host-bl-test "is-type? recognises type posts (article, card-image) but not a plain instance"
|
||||
(begin
|
||||
(host/blog-put! "plainpost" "PP" "(p \"x\")" "published")
|
||||
(list (host/blog--is-type? "article") (host/blog--is-type? "card-image") (host/blog--is-type? "plainpost")))
|
||||
(list true true false))
|
||||
(host-bl-test "set-field-grammar! updates a Composition field's :blocks + :allow"
|
||||
(begin
|
||||
(host/blog-seed! "dt" "DT" "(p)" "published") (host/blog-relate! "dt" "type" "subtype-of")
|
||||
(host/blog--set-fields! "dt" (list {:name "body" :type "Composition"}))
|
||||
(host/blog--set-field-grammar! "dt" "body" (list "card-text") (list "each"))
|
||||
(let ((f (host/blog--own-field "dt" "body")))
|
||||
(list (get f :blocks) (get f :allow))))
|
||||
(list (list "card-text") (list "each")))
|
||||
(host-bl-test "the type-def editor renders a grammar checklist for a Composition field"
|
||||
(let ((html (render-page (host/blog--type-def-editor "article"))))
|
||||
(list (contains? html "Type definition") (contains? html "may contain")
|
||||
(contains? html "blk-card-image") (contains? html "allow-cond")))
|
||||
(list true true true true))
|
||||
(host-bl-test "POST /<type>/grammar sets the grammar from the checklist"
|
||||
(begin
|
||||
(host/blog-seed! "dt2" "DT2" "(p)" "published") (host/blog-relate! "dt2" "type" "subtype-of")
|
||||
(host/blog--set-fields! "dt2" (list {:name "body" :type "Composition"}))
|
||||
(host-bl-wapp (host-bl-send "POST" "/dt2/grammar" "Bearer good"
|
||||
"application/x-www-form-urlencoded" "field=body&blk-card-text=on&blk-card-heading=on&allow-cond=on"))
|
||||
(let ((f (host/blog--own-field "dt2" "body")))
|
||||
(list (contains? (get f :blocks) "card-text") (contains? (get f :blocks) "card-heading")
|
||||
(contains? (get f :blocks) "card-image") (get f :allow))))
|
||||
(list true true false (list "cond")))
|
||||
;; a type's edit page SHOWS the type-def editor; an instance's does not.
|
||||
(host-bl-test "the type-def editor appears on a type's edit page, not an instance's"
|
||||
(list (contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/article/edit" "Bearer good" "" ""))) "Type definition")
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/my-first-post/edit" "Bearer good" "" ""))) "Type definition"))
|
||||
(list true false))
|
||||
;; 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