diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 6473bfe4..a656b301 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -635,12 +635,22 @@ (if (empty? (rest args)) "" (str (first (rest args))))) ((= (type-of (first args)) "keyword") (loop (rest (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. (define host/blog--tag->card-type (fn (tag) (cond ((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") ((or (= tag "pre") (= tag "code")) "card-code") (else "card-text")))) @@ -650,8 +660,13 @@ (cond ((= ctype "card-heading") {"level" (if (>= (len orig-tag) 2) (substr orig-tag 1) "2") "text" (host/blog--elem-text block)}) - ((= ctype "card-image") {"src" (host/blog--elem-attr block "src") - "alt" (host/blog--elem-attr block "alt") "caption" ""}) + ((= ctype "card-image") + ;; a bare (src/alt on the block) OR a
(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-quote") {"text" (host/blog--elem-text block) "cite" ""}) (else {"text" (host/blog--elem-text block)})))) @@ -1128,7 +1143,11 @@ ;; template: a subtitle (plain text) and an optional hero image URL. (host/blog--set-fields! "article" (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 ;; above the body. (field "subtitle") resolves to the instance's value at render. (host/blog--set-template! "article" @@ -1159,7 +1178,7 @@ "(pre (code (field \"code\")))") (host/blog--seed-card-type! "card-embed" "Embed" (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" (list {:name "style" :type "String"} {:name "text" :type "Text"}) "(div :class \"callout\" (field \"text\"))") @@ -2162,7 +2181,7 @@ (let ((relation-editors (host/blog--relation-editors slug)) (block-editor (host/blog--block-editors 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)) (mk-opt (fn (val label) @@ -2211,7 +2230,7 @@ (let ((title (or (host/field req "title") (get r :title))) (sx-content (or (host/field req "sx_content") "")) (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 ;; schema requirement the post's types impose. Empty = save. (let ((issues (if (host/blog-content-ok? sx-content) diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 163357ab..4b5860b8 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -612,7 +612,7 @@ ;; -- Slice 8: typed scalar fields on a type -- (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")) - (list "subtitle" "hero")) + (list "subtitle" "hero" "body")) (host-bl-test "widget-for: explicit > value-type default > text fallback" (list (host/blog--widget-for {:name "a" :type "URL"}) (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" (begin (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 "Article" 2)) + (list "Article" 3)) (host-bl-test "a type with no declared fields -> empty list" (host/blog-fields-of "tag") (list)) (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-relate! "fpost" "article" "is-a") (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/blog--fields-for-post "hello") (list)) (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/"))))) (list (contains? html "Heading One") (contains? html "Para text.") (contains? html "p.jpg"))) (list true true true)) +;; real-post block kinds: a
-> card-image WITH its figcaption; an