host: article declares :body composition + decompose real posts (figure/iframe→cards)

Prep for importing a real blog post into the :body composition:
- article now DECLARES {:name "body" :type "Composition"} (layer 2 — the type defines that an
  article's body is a composition). The edit FORM + submit read scalar-fields only, so the
  Composition field never gets a stray text input (or gets nil'd on save).
- decompose handles real-post block kinds: <figure> → card-image WITH its <figcaption> as the
  caption (host/blog--find-child digs out the inner <img>); <iframe>/<embed>/<video> →
  card-embed with src as :url. card-embed's template now renders an actual <iframe> (videos
  play) instead of the url as text.

blog 175/175, full host conformance 404/404 (+ test: figure→card-image(caption) & iframe→
card-embed via import). Next: wipe content (reseed types+demos), import nt-live-encore.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
2026-07-01 11:35:29 +00:00
parent 616c3cf966
commit a8c095b1b3
2 changed files with 42 additions and 11 deletions

View File

@@ -635,12 +635,22 @@
(if (empty? (rest args)) "" (str (first (rest args))))) (if (empty? (rest args)) "" (str (first (rest args)))))
((= (type-of (first args)) "keyword") (loop (rest (rest args)))) ((= (type-of (first args)) "keyword") (loop (rest (rest args))))
(else (loop (rest args))))))) (else (loop (rest args)))))))
;; the first child element of `node` with tag `tag` (a list head), or nil. (For a figure's
;; inner img / figcaption during decompose.)
(define host/blog--find-child
(fn (node tag)
(let loop ((xs (if (= (type-of node) "list") (rest node) (list))))
(cond
((empty? xs) nil)
((and (= (type-of (first xs)) "list") (= (str (first (first xs))) tag)) (first xs))
(else (loop (rest xs)))))))
;; map an element tag to a card-type (the block vocabulary). Unknown tags -> text card. ;; map an element tag to a card-type (the block vocabulary). Unknown tags -> text card.
(define host/blog--tag->card-type (define host/blog--tag->card-type
(fn (tag) (fn (tag)
(cond (cond
((or (= tag "h1") (= tag "h2") (= tag "h3") (= tag "h4")) "card-heading") ((or (= tag "h1") (= tag "h2") (= tag "h3") (= tag "h4")) "card-heading")
((= tag "img") "card-image") ((or (= tag "img") (= tag "figure")) "card-image") ;; figure = image + figcaption
((or (= tag "iframe") (= tag "embed") (= tag "video")) "card-embed")
((= tag "blockquote") "card-quote") ((= tag "blockquote") "card-quote")
((or (= tag "pre") (= tag "code")) "card-code") ((or (= tag "pre") (= tag "code")) "card-code")
(else "card-text")))) (else "card-text"))))
@@ -650,8 +660,13 @@
(cond (cond
((= ctype "card-heading") {"level" (if (>= (len orig-tag) 2) (substr orig-tag 1) "2") ((= ctype "card-heading") {"level" (if (>= (len orig-tag) 2) (substr orig-tag 1) "2")
"text" (host/blog--elem-text block)}) "text" (host/blog--elem-text block)})
((= ctype "card-image") {"src" (host/blog--elem-attr block "src") ((= ctype "card-image")
"alt" (host/blog--elem-attr block "alt") "caption" ""}) ;; a bare <img> (src/alt on the block) OR a <figure> (img child + a figcaption caption).
(let ((img (or (host/blog--find-child block "img") block))
(cap (host/blog--find-child block "figcaption")))
{"src" (host/blog--elem-attr img "src") "alt" (host/blog--elem-attr img "alt")
"caption" (if (nil? cap) "" (host/blog--elem-text cap))}))
((= ctype "card-embed") {"url" (host/blog--elem-attr block "src") "caption" ""})
((= ctype "card-code") {"code" (host/blog--elem-text block) "language" ""}) ((= ctype "card-code") {"code" (host/blog--elem-text block) "language" ""})
((= ctype "card-quote") {"text" (host/blog--elem-text block) "cite" ""}) ((= ctype "card-quote") {"text" (host/blog--elem-text block) "cite" ""})
(else {"text" (host/blog--elem-text block)})))) (else {"text" (host/blog--elem-text block)}))))
@@ -1128,7 +1143,11 @@
;; template: a subtitle (plain text) and an optional hero image URL. ;; template: a subtitle (plain text) and an optional hero image URL.
(host/blog--set-fields! "article" (host/blog--set-fields! "article"
(list {:name "subtitle" :type "String"} (list {:name "subtitle" :type "String"}
{:name "hero" :type "URL"})) {: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"}))
;; article's render TEMPLATE (Slice 8c) — the subtitle field shown as a standfirst ;; 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. ;; above the body. (field "subtitle") resolves to the instance's value at render.
(host/blog--set-template! "article" (host/blog--set-template! "article"
@@ -1159,7 +1178,7 @@
"(pre (code (field \"code\")))") "(pre (code (field \"code\")))")
(host/blog--seed-card-type! "card-embed" "Embed" (host/blog--seed-card-type! "card-embed" "Embed"
(list {:name "url" :type "URL"} {:name "caption" :type "String"}) (list {:name "url" :type "URL"} {:name "caption" :type "String"})
"(div :class \"embed\" (field \"url\"))") "(div :class \"embed\" :style \"margin:1em 0\" (iframe :src (field \"url\") :width \"560\" :height \"315\" :frameborder \"0\" :allowfullscreen \"\" :style \"max-width:100%\"))")
(host/blog--seed-card-type! "card-callout" "Callout" (host/blog--seed-card-type! "card-callout" "Callout"
(list {:name "style" :type "String"} {:name "text" :type "Text"}) (list {:name "style" :type "String"} {:name "text" :type "Text"})
"(div :class \"callout\" (field \"text\"))") "(div :class \"callout\" (field \"text\"))")
@@ -2162,7 +2181,7 @@
(let ((relation-editors (host/blog--relation-editors slug)) (let ((relation-editors (host/blog--relation-editors slug))
(block-editor (host/blog--block-editors slug)) (block-editor (host/blog--block-editors slug))
(tag-toggle (host/blog--is-tag-toggle slug)) (tag-toggle (host/blog--is-tag-toggle slug))
(post-fields (host/blog--fields-for-post slug)) (post-fields (host/blog--scalar-fields slug))
(field-values (host/blog-field-values-of slug)) (field-values (host/blog-field-values-of slug))
(mk-opt (mk-opt
(fn (val label) (fn (val label)
@@ -2211,7 +2230,7 @@
(let ((title (or (host/field req "title") (get r :title))) (let ((title (or (host/field req "title") (get r :title)))
(sx-content (or (host/field req "sx_content") "")) (sx-content (or (host/field req "sx_content") ""))
(status (or (host/field req "status") (get r :status))) (status (or (host/field req "status") (get r :status)))
(post-fields (host/blog--fields-for-post slug))) (post-fields (host/blog--scalar-fields slug)))
;; collect issues up front (perform): unparseable markup, then each ;; collect issues up front (perform): unparseable markup, then each
;; schema requirement the post's types impose. Empty = save. ;; schema requirement the post's types impose. Empty = save.
(let ((issues (if (host/blog-content-ok? sx-content) (let ((issues (if (host/blog-content-ok? sx-content)

View File

@@ -612,7 +612,7 @@
;; -- Slice 8: typed scalar fields on a type -- ;; -- Slice 8: typed scalar fields on a type --
(host-bl-test "fields-of reads a type's declared fields (seeded on article)" (host-bl-test "fields-of reads a type's declared fields (seeded on article)"
(map (fn (f) (get f :name)) (host/blog-fields-of "article")) (map (fn (f) (get f :name)) (host/blog-fields-of "article"))
(list "subtitle" "hero")) (list "subtitle" "hero" "body"))
(host-bl-test "widget-for: explicit > value-type default > text fallback" (host-bl-test "widget-for: explicit > value-type default > text fallback"
(list (host/blog--widget-for {:name "a" :type "URL"}) (list (host/blog--widget-for {:name "a" :type "URL"})
(host/blog--widget-for {:name "b" :type "Text"}) (host/blog--widget-for {:name "b" :type "Text"})
@@ -622,9 +622,9 @@
(host-bl-test "set-fields! is idempotent + preserves the rest of the record" (host-bl-test "set-fields! is idempotent + preserves the rest of the record"
(begin (begin
(host/blog--set-fields! "article" (host/blog--set-fields! "article"
(list {:name "subtitle" :type "String"} {:name "hero" :type "URL"})) (list {:name "subtitle" :type "String"} {:name "hero" :type "URL"} {:name "body" :type "Composition"}))
(list (get (host/blog-get "article") :title) (len (host/blog-fields-of "article")))) (list (get (host/blog-get "article") :title) (len (host/blog-fields-of "article"))))
(list "Article" 2)) (list "Article" 3))
(host-bl-test "a type with no declared fields -> empty list" (host-bl-test "a type with no declared fields -> empty list"
(host/blog-fields-of "tag") (list)) (host/blog-fields-of "tag") (list))
(host-bl-test "/meta shows the article's typed fields" (host-bl-test "/meta shows the article's typed fields"
@@ -636,7 +636,7 @@
(host/blog-put! "fpost" "F Post" "(article (h1 \"F\"))" "published") (host/blog-put! "fpost" "F Post" "(article (h1 \"F\"))" "published")
(host/blog-relate! "fpost" "article" "is-a") (host/blog-relate! "fpost" "article" "is-a")
(map (fn (f) (get f :name)) (host/blog--fields-for-post "fpost"))) (map (fn (f) (get f :name)) (host/blog--fields-for-post "fpost")))
(list "subtitle" "hero")) (list "subtitle" "hero" "body"))
(host-bl-test "a post of no typed type has no fields" (host-bl-test "a post of no typed type has no fields"
(host/blog--fields-for-post "hello") (list)) (host/blog--fields-for-post "hello") (list))
(host-bl-test "set/get field-values round-trips on an instance" (host-bl-test "set/get field-values round-trips on an instance"
@@ -823,6 +823,18 @@
(let ((html (dream-resp-body (host-bl-app (host-bl-req "/imp-x/"))))) (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 (contains? html "Heading One") (contains? html "Para text.") (contains? html "p.jpg")))
(list true true true)) (list true true true))
;; real-post block kinds: a <figure> -> card-image WITH its figcaption; an <iframe> ->
;; card-embed with its src as the url. (The nt-live-encore import shape.)
(host-bl-test "decompose maps figure->card-image (with caption) and iframe->card-embed"
(begin
(host/blog-import-post! {"slug" "imp-fig" "title" "Fig" "status" "published"
"sx_content" "(article (figure (img :src \"p.jpg\" :alt \"a\") (figcaption \"the cap\")) (iframe :src \"https://youtube.com/embed/xyz\"))"})
(list (host/blog-is-a? "imp-fig__body__b0" "card-image")
(get (host/blog-field-values-of "imp-fig__body__b0") "caption")
(get (host/blog-field-values-of "imp-fig__body__b0") "src")
(host/blog-is-a? "imp-fig__body__b1" "card-embed")
(get (host/blog-field-values-of "imp-fig__body__b1") "url")))
(list true "the cap" "p.jpg" true "https://youtube.com/embed/xyz"))
;; -- block editor: structural edits to the post :body composition (step 6). -- ;; -- 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" (host-bl-test "block-add! creates a card object + contains edge + appends a ref to the body"
(begin (begin