host: type pages are self-documenting — definition + POPULATION

Every type post reads as schema + extension. Added host/blog--type-population (host/blog--take
helper): a type's page shows its instances (posts is-a it, first 24 + count) and its subtypes
(is-a / subtype-of inverses), next to the read-only type definition. Injected in host/blog-post
when host/blog--is-type?. So /article/ shows what an article IS *and* which posts are articles;
/card/ shows its subtypes; every card type / tag / type reads its own definition (all are
is-type?).

blog 194/194 (+ tests: population lists instances + count, a parent type lists subtypes, GET
/article/ shows Population).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
2026-07-01 15:17:51 +00:00
parent 92b8007a76
commit fc7ec99037
2 changed files with 37 additions and 0 deletions

View File

@@ -1927,6 +1927,29 @@
(cons (quote ul) (append (quasiquote (:style "margin:0.3em 0")) rows)) (cons (quote ul) (append (quasiquote (:style "margin:0.3em 0")) rows))
(quote (p :style "color:#999;margin:0" "No declared fields.")))) (quote (p :style "color:#999;margin:0" "No declared fields."))))
(p :style "margin:0.4em 0 0" (b "Instances may be linked by: ") (unquote (join ", " rels))))))))) (p :style "margin:0.4em 0 0" (b "Instances may be linked by: ") (unquote (join ", " rels)))))))))
;; the first n elements of a list.
(define host/blog--take
(fn (xs n) (let loop ((ys xs) (k n) (acc (list)))
(if (or (empty? ys) (<= k 0)) acc (loop (rest ys) (- k 1) (concat acc (list (first ys))))))))
;; a type's POPULATION — its instances (posts is-a this type) + subtypes — shown on the type's
;; public page next to its definition (schema + extension). Durable reads: call in a handler.
(define host/blog--type-population
(fn (slug)
(let ((instances (host/blog-in slug "is-a"))
(subtypes (host/blog-in slug "subtype-of")))
(let ((inst-links (map (fn (s) (quasiquote (li (a :href (unquote (str "/" s "/")) (unquote s)))))
(host/blog--take instances 24))))
(quasiquote
(aside :style "margin-top:1em;border:1px solid #ccc;background:#fafafa;padding:0.8em 1em;border-radius:4px"
(h3 :style "margin:0 0 0.4em;font-size:1em"
(unquote (str "Population — " (len instances) " instance" (if (= (len instances) 1) "" "s"))))
(unquote (if (> (len subtypes) 0)
(quasiquote (p :style "margin:0.2em 0" (b "Subtypes: ") (unquote (join ", " subtypes))))
""))
(unquote (if (> (len instances) 0)
(cons (quote ul) (append (quasiquote (:style "margin:0.3em 0")) inst-links))
(quote (p :style "color:#999;margin:0" "No instances yet."))))
(unquote (if (> (len instances) 24) (quote (p :style "color:#999;margin:0" "… (showing first 24)")) ""))))))))
;; ── read handlers ─────────────────────────────────────────────────── ;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw. ;; Post body is rendered per-block (a guarded HTML string) then injected raw.
@@ -1957,6 +1980,7 @@
;; a TYPE post shows its definition (fields + grammar + relations) publicly — ;; a TYPE post shows its definition (fields + grammar + relations) publicly —
;; read-only; the edit page has the writable form. ;; read-only; the edit page has the writable form.
(type-def-view (if (host/blog--is-type? slug) (host/blog--type-def-view slug) "")) (type-def-view (if (host/blog--is-type? slug) (host/blog--type-def-view slug) ""))
(type-population (if (host/blog--is-type? slug) (host/blog--type-population slug) ""))
(auth-foot (host/auth-footer req))) (auth-foot (host/auth-footer req)))
(host/blog--resp req 200 (host/blog--resp req 200
(host/blog--page req (get r :title) (host/blog--page req (get r :title)
@@ -1965,6 +1989,7 @@
(unquote typed-block) (unquote typed-block)
(article (raw! (unquote body-html))) (article (raw! (unquote body-html)))
(unquote type-def-view) (unquote type-def-view)
(unquote type-population)
(unquote relations) (unquote relations)
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8" (p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href (unquote (str "/" slug "/source")) "view source") (a :href (unquote (str "/" slug "/source")) "view source")

View File

@@ -1050,6 +1050,18 @@
(list (contains? (dream-resp-body (host-bl-app (host-bl-req "/article/"))) "Type definition") (list (contains? (dream-resp-body (host-bl-app (host-bl-req "/article/"))) "Type definition")
(contains? (dream-resp-body (host-bl-app (host-bl-req "/my-first-post/"))) "Type definition")) (contains? (dream-resp-body (host-bl-app (host-bl-req "/my-first-post/"))) "Type definition"))
(list true false)) (list true false))
;; a type's page shows its POPULATION too — instances (is-a) + subtypes (schema + extension).
(host-bl-test "the type-population section lists a type's instances + count"
(begin
(host/blog-put! "pop-inst" "PopInst" "(article (h1 \"x\"))" "published")
(host/blog-relate! "pop-inst" "article" "is-a")
(let ((html (render-page (host/blog--type-population "article"))))
(list (contains? html "Population") (contains? html "pop-inst") (contains? html "instance"))))
(list true true true))
(host-bl-test "a parent type's population lists its subtypes"
(contains? (render-page (host/blog--type-population "card")) "Subtypes") true)
(host-bl-test "GET /article/ shows the Population section"
(contains? (dream-resp-body (host-bl-app (host-bl-req "/article/"))) "Population") true)
;; the editor renders a HAND-AUTHORED composition (text/row/alt-with-text) WITHOUT falling ;; 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). ;; 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)" (host-bl-test "the block editor renders text/layout/inline-alt nodes (no unknown block)"