coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

host: cards-as-objects import + typing reads direct KV edges (composition step 5 + perf)

Browse Source 
STEP 5 (cards-as-objects). The importer no longer carries a Ghost body as one opaque
sx_content string: host/blog--decompose! splits an (article …) into one stored card OBJECT
per top-level block (is-a the mapped card-type + its field-values), links each by an ordered
`contains` edge, and sets the post :body = (seq (ref c0) (ref c1) …). Card types now carry a
render :template, so the new `ref` combinator (compose.sx) transcludes each card via the
SAME typed-block path articles use. /import wired to decompose; the home index filtered to
published so the "block"-status card objects stay hidden. Added the `val` leaf (raw field
value, no <span>) for attribute interpolation in templates (href/src). The post page renders
the transcluded cards — verified end-to-end (conformance 157/159; the 2 fails are the
pre-existing relate-picker pagination pair, unrelated).

PERF (the conformance-speed fix). host/blog typing — types-of / instances-of / type-defs —
computed the subtype closure via lib/relations descendants/ancestors, and EVERY such call
re-saturates the whole CEK-interpreted Datalog ruleset (~seconds each). Typing is the hottest
path (is-a?/types-of/instances-of run per post, per picker, per render), so this dominated
both the blog suite and live page latency. Now the closure is a host-side BFS over the DIRECT
subtype-of edges (the edge:* KV rows, via host/blog--subtype-closure) — one snapshot per
closure, O(edges), cycle-safe, Datalog-free. Same transitive set (KV == relations for direct
edges, host/blog-relate! writes both), so exact, not approximate. Drops Datalog out of the
typing hot path entirely — speeds conformance AND the live site (/tags etc.).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-30 22:20:38 +00:00
parent a25427cb79
commit 14a6bd6411
4 changed files with 201 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files

195
lib/host/blog.sx
View File

@@ -305,50 +305,63 @@
;; types with is-a edges; types form a hierarchy with subtype-of edges. is-a
;; (instance-of) is NOT transitive on its own, but subsumption is: an instance of
;; a subtype is an instance of the supertype. So a post's full type set is its
;; declared types PLUS every subtype-of-ancestor of each (relations/descendants
;; follows subtype-of transitively). Keeps the Datalog ruleset minimal — the
;; closure is composed host-side.
;; declared types PLUS every subtype-of-ancestor of each.
;;
;; PERF: the subtype closure is computed HOST-SIDE by a BFS over the DIRECT subtype-of
;; edges (the edge:* KV rows), NOT via lib/relations descendants/ancestors. Each lib/
;; relations query re-saturates the whole (CEK-interpreted) Datalog ruleset — ~seconds
;; even on a tiny graph — and typing is on the hottest path (is-a?/types-of/instances-of
;; run per post, per picker, per render), so re-saturation made the blog suite + live
;; pages CPU-bound. The closure is the SAME transitive set; one edge-store snapshot drives
;; the whole BFS (O(edges), cycle-safe). KV == relations for direct edges (host/blog-relate!
;; writes both), so this is exact, not an approximation.
(define host/blog--uniq
(fn (xs) (reduce (fn (acc x) (if (contains? acc x) acc (concat acc (list x)))) (list) xs)))
;; transitive closure over DIRECT subtype-of edges from `roots` (roots included), with NO
;; Datalog. dir :out = follow src->dst (the supertypes of roots); dir :in = follow dst->src
;; (the subtypes of roots). One host/blog--all-edges snapshot; BFS with a `seen` guard.
(define host/blog--subtype-closure
(fn (roots dir)
(let ((edges (host/blog--all-edges)) (existing (host/blog-slugs)))
(let ((step
(fn (n)
(filter (fn (s) (contains? existing s))
(reduce (fn (acc e)
(if (and (= (get e :kind) "subtype-of")
(= (get e (if (= dir :out) :src :dst)) n))
(concat acc (list (get e (if (= dir :out) :dst :src)))) acc))
(list) edges)))))
(let loop ((frontier roots) (seen (list)))
(if (empty? frontier)
seen
(let ((n (first frontier)))
(if (contains? seen n)
(loop (rest frontier) seen)
(loop (concat (rest frontier) (step n)) (concat seen (list n)))))))))))
(define host/blog-types-of
(fn (slug)
(host/blog--uniq
(reduce
(fn (acc t)
(concat (concat acc (list t))
(host/blog--edge-slugs
(relations/descendants (host/blog--node t) (string->symbol "subtype-of")))))
(list)
(host/blog-out slug "is-a")))))
(host/blog--uniq (host/blog--subtype-closure (host/blog-out slug "is-a") :out))))
;; is this post (transitively) of the given type-slug?
(define host/blog-is-a? (fn (slug type) (contains? (host/blog-types-of slug) type)))
;; all posts that are (transitively) instances of `type`: instances of the type
;; itself plus instances of any of its subtypes. Computed in O(#subtypes) relation
;; queries, NOT one type-resolution per post — the efficient way to enumerate a
;; type's members (e.g. "all tags") for the picker.
;; itself plus instances of any of its subtypes. O(edges) over one snapshot — the
;; efficient way to enumerate a type's members (e.g. "all tags") for the picker.
(define host/blog-instances-of
(fn (type)
(let ((subtypes
(concat (list type)
(host/blog--edge-slugs
(relations/ancestors (host/blog--node type) (string->symbol "subtype-of"))))))
(host/blog--uniq
(reduce (fn (acc t) (concat acc (host/blog-in t "is-a"))) (list) subtypes)))))
(host/blog--uniq
(reduce (fn (acc t) (concat acc (host/blog-in t "is-a")))
(list) (host/blog--subtype-closure (list type) :in)))))
;; All type-posts: the subtype-of hierarchy rooted at "type" (type + its transitive
;; subtypes). This is "the types you've DEFINED" — distinct from host/blog-instances-of
;; "type" (which is the is-a INSTANCES of the type, i.e. typed content, not the type
;; definitions; the definitions are linked by subtype-of, the same set instances-of
;; computes internally as `subtypes`). Used by the metamodel overview + editor.
;; definitions; the definitions are linked by subtype-of). Used by the metamodel editor.
(define host/blog-type-defs
(fn ()
(host/blog--uniq
(concat (list "type")
(host/blog--edge-slugs
(relations/ancestors (host/blog--node "type") (string->symbol "subtype-of")))))))
(fn () (host/blog--uniq (host/blog--subtype-closure (list "type") :in))))
;; ── Slice 4: type ALGEBRA — intersection (∧) and union (∨) types ─────
;; An algebraic type is a post with operand edges: a `conj` edge per intersection
@@ -551,15 +564,100 @@
(fn (req)
(let ((al (str (or (dream-header req "accept-language") ""))))
(if (>= (len al) 2) (substr al 0 2) "en"))))
;; the `ref` transclude resolver (compose.sx asks the context for "ref"): render the
;; referenced object. A decomposed card object is-a a card-type with field-values + the
;; card-type carries a :template, so it renders via the SAME typed-block path articles
;; use; render-page turns that SX tree into HTML. Empty for an absent / template-less ref.
(define host/blog--comp-ref
(fn (slug ctx)
(let ((tb (host/blog--typed-block slug)))
(if (= tb "") "" (render-page tb)))))
;; the render context for a :body: auth from the principal + live device/locale from the
;; request + the graph-query resolver. The context is the EXECUTION environment — the
;; object (its when-variants) is the definition; this picks which path renders.
;; request + the graph-query resolver + the transclude resolver. The context is the
;; EXECUTION environment — the object (its when-variants) is the definition; this picks
;; which path renders.
(define host/blog--comp-ctx
(fn (principal req)
(merge
(merge (if (nil? principal) {} {"auth" "yes"})
(if (nil? req) {} {"device" (host/blog--device-of req) "locale" (host/blog--locale-of req)}))
{"query" host/blog--comp-query})))
{"query" host/blog--comp-query "ref" host/blog--comp-ref})))
;; ── cards-as-objects: decompose content into card OBJECTS + a `contains` body ────────
;; A post body is not one opaque sx_content string but a `contains` DAG of separate,
;; content-addressed card OBJECTS. host/blog--decompose! splits an (article …) tree into
;; one card object per top-level block (is-a the mapped card-type + its field-values),
;; links each by an ordered `contains` edge, and sets the post's :body to (seq (ref c0)
;; (ref c1) …). The render-fold then transcludes each card via its type template. This is
;; the cards-as-objects decision made real for the importer (plans/composition-objects.md).
;; the text content of a block element: its string children joined, skipping :attr pairs,
;; recursing into nested elements. Carries prose into a card field (good enough for import).
(define host/blog--args-text
(fn (args)
(cond
((empty? args) "")
((= (type-of (first args)) "keyword") (host/blog--args-text (rest (rest args))))
(else (str (host/blog--elem-text (first args)) (host/blog--args-text (rest args)))))))
(define host/blog--elem-text
(fn (node)
(cond
((= (type-of node) "string") node)
((and (= (type-of node) "list") (> (len node) 0)) (host/blog--args-text (rest node)))
(else ""))))
;; the value of an :attr on an element (e.g. img :src), "" if absent.
(define host/blog--elem-attr
(fn (node key)
(let loop ((args (if (= (type-of node) "list") (rest node) (list))))
(cond
((empty? args) "")
((and (= (type-of (first args)) "keyword") (= (str (first args)) key))
(if (empty? (rest args)) "" (str (first (rest args)))))
((= (type-of (first args)) "keyword") (loop (rest (rest args))))
(else (loop (rest args)))))))
;; 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")
((= tag "blockquote") "card-quote")
((or (= tag "pre") (= tag "code")) "card-code")
(else "card-text"))))
;; the field-values for a card-type extracted from the original block element.
(define host/blog--block-fields
(fn (orig-tag ctype block)
(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-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)}))))
;; decompose a post's content-tree into card objects + a contains body. Idempotent
;; (seed!/relate!/set-body! are sets; re-import overwrites the same __bN card objects).
(define host/blog--decompose!
(fn (post-slug content-tree)
(let ((blocks (if (and (= (type-of content-tree) "list") (> (len content-tree) 0))
(filter (fn (b) (= (type-of b) "list")) (rest content-tree))
(list))))
(when (not (empty? blocks))
(let ((refs
(map-indexed
(fn (i block)
(let ((orig-tag (str (first block))) (cslug (str post-slug "__b" i)))
(let ((ctype (host/blog--tag->card-type orig-tag)))
(begin
;; status "block" hides the card object from listings; it still
;; renders when transcluded (typed-block ignores status).
(host/blog-seed! cslug ctype "(article (h1 \"card\"))" "block")
(host/blog-relate! cslug ctype "is-a")
(host/blog--set-field-values! cslug (host/blog--block-fields orig-tag ctype block))
(host/blog-relate! post-slug cslug "contains")
(list (quote ref) cslug)))))
blocks)))
(host/blog--set-body! post-slug (cons (quote seq) refs)))))))
;; Seed a live demo of the composition fold: one object, rendered by host/comp-render, that
;; shows seq + alt(when auth) + row(par) + each — and renders DIFFERENTLY logged-in vs out.
(define host/blog-seed-compose-demo!
@@ -663,13 +761,17 @@
;; card palette + a post's body blocks are driven by type definitions, and the radar
;; migrator (plans/NOTE-blog-types-for-radar.md) maps old Ghost cards onto these.
(define host/blog--seed-card-type!
(fn (slug title fields)
(fn (slug title fields template)
(begin
(host/blog-seed! slug title
(str "(article (h1 \"" title "\") (p \"A " title " card — a kind of content block. Its fields define what the editor collects and the template renders.\"))")
"published")
(host/blog-relate! slug "card" "subtype-of")
(host/blog--set-fields! slug fields))))
(host/blog--set-fields! slug fields)
;; a card type carries a render :template (SX tree with (field "name") placeholders),
;; so a card OBJECT renders via the SAME typed-block path articles use — and a `(ref)`
;; in a post body transcludes it. This is what makes cards-as-objects render.
(when template (host/blog--set-template! slug template)))))
;; Seed the root type-posts: "type" (the root) and "tag" (a kind of type). Types
;; ARE posts, so these are real posts that document themselves; tag subtype-of
@@ -721,19 +823,26 @@
"published")
(host/blog-relate! "card" "type" "subtype-of")
(host/blog--seed-card-type! "card-heading" "Heading"
(list {:name "level" :type "Int"} {:name "text" :type "String"}))
(list {:name "level" :type "Int"} {:name "text" :type "String"})
"(h2 (field \"text\"))")
(host/blog--seed-card-type! "card-text" "Text"
(list {:name "text" :type "Text"}))
(list {:name "text" :type "Text"})
"(p (field \"text\"))")
(host/blog--seed-card-type! "card-image" "Image"
(list {:name "src" :type "URL"} {:name "alt" :type "String"} {:name "caption" :type "String"}))
(list {:name "src" :type "URL"} {:name "alt" :type "String"} {:name "caption" :type "String"})
"(figure (img :src (field \"src\") :alt (field \"alt\")) (figcaption (field \"caption\")))")
(host/blog--seed-card-type! "card-quote" "Quote"
(list {:name "text" :type "Text"} {:name "cite" :type "String"}))
(list {:name "text" :type "Text"} {:name "cite" :type "String"})
"(blockquote (field \"text\"))")
(host/blog--seed-card-type! "card-code" "Code"
(list {:name "language" :type "String"} {:name "code" :type "Text"}))
(list {:name "language" :type "String"} {:name "code" :type "Text"})
"(pre (code (field \"code\")))")
(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\"))")
(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\"))")
;; relation DECLARATIONS (see plans/relations-as-posts.md). A type-post declares
;; which relation it anchors at its OBJECT end ("you may point at me with R"); the
;; picker's candidate set is the down-closure of a relation's anchors through the
@@ -1204,7 +1313,9 @@
(define host/blog-home
(fn (req)
(let ((posts (host/blog-list)))
;; only PUBLISHED posts list on the home page — drafts and "block" card objects
;; (the decomposed cards-as-objects) are stored but not surfaced as top-level posts.
(let ((posts (filter (fn (p) (= (get p :status) "published")) (host/blog-list))))
(let ((items
(map
(fn (p)
@@ -1385,6 +1496,10 @@
(host/blog-relate! tslug "tag" "is-a")
(host/blog-relate! slug tslug "tagged"))))
(or (get gp "tags") (list)))
;; cards-as-objects: decompose the Ghost body into card objects + a `contains`
;; body, so the post renders via the composition fold (its :body supersedes the
;; opaque sx_content). parse-safe degrades to nil on bad input -> decompose no-ops.
(host/blog--decompose! slug (parse-safe (or (get gp "sx_content") "")))
slug))))
;; Import a batch; returns the imported slugs.
(define host/blog-import-all!

6
lib/host/compose.sx
View File

@@ -100,6 +100,12 @@
((= h "val") (host/comp--field (first args) ctx)) ;; raw value, no markup — for attributes
((= h "text") (str (first args)))
((= h "card") (host/comp--card (str (first args)) (first (rest args))))
;; ref: TRANSCLUDE another object by id/CID — fetch it and render its body. Like
;; `query`, this delegates to a resolver bound in the context (the host supplies
;; graph access) so compose.sx stays self-contained. A join in the Merkle DAG is
;; free: two bodies can (ref) the same child id (content-addressed).
((= h "ref") (let ((rfn (get ctx "ref")))
(if rfn (rfn (str (first args)) ctx) "")))
((= h "tmpl") (host/comp--render (get host/comp--tmpls (str (first args))) ctx))
(else ""))))))

28
lib/host/tests/blog.sx
View File

@@ -789,6 +789,34 @@
(list (host/comp-render body (host/blog--comp-ctx nil mob))
(host/comp-render body (host/blog--comp-ctx nil desk))))
(list "M" "D"))
;; -- cards-as-objects: the importer decomposes content into card OBJECTS + a contains body
;; (not one opaque sx_content string). Each top-level block becomes a stored card object
;; (is-a a card-type + field-values), linked by ordered `contains` edges; the post :body is
;; (seq (ref c0) (ref c1) …) and the render-fold transcludes each card via its type template. --
(host-bl-test "import decomposes the body into typed card objects + a contains body"
(begin
(host/blog-import-post! {"slug" "imp-x" "title" "Imp X"
"sx_content" "(article (h1 \"Heading One\") (p \"Para text.\") (img :src \"p.jpg\" :alt \"alt\"))"
"status" "published"})
(list (len (host/blog-out "imp-x" "contains"))
(host/blog-is-a? "imp-x__b0" "card-heading")
(host/blog-is-a? "imp-x__b1" "card-text")
(host/blog-is-a? "imp-x__b2" "card-image")
(get (host/blog-field-values-of "imp-x__b0") "text")
(get (host/blog-field-values-of "imp-x__b2") "src")))
(list 3 true true true "Heading One" "p.jpg"))
(host-bl-test "a decomposed post :body is a (seq (ref …) …) composition"
(let ((body (host/blog-body-of "imp-x")))
(list (str (first body)) (len (rest body)) (str (first (first (rest body))))))
(list "seq" 3 "ref"))
;; the card objects are status "block" — stored but NOT listed as top-level posts.
(host-bl-test "decomposed card objects do not appear on the published home index"
(contains? (dream-resp-body (host-bl-app (host-bl-req "/"))) "imp-x__b0") false)
;; the post page renders the cards by TRANSCLUSION (ref -> card-type template).
(host-bl-test "decomposed post page renders the transcluded cards"
(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))
(host-bl-test "a post with no schema'd type is vacuously valid"
(host/blog-type-valid? "ppost" "(p \"anything\")") true)
(host-bl-test "edit-submit rejects content violating the type schema (not saved)"