diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 44f3b3a4..b765e9c8 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -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! diff --git a/lib/host/compose.sx b/lib/host/compose.sx index 1648e2af..d061abab 100644 --- a/lib/host/compose.sx +++ b/lib/host/compose.sx @@ -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 "")))))) diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 0d28c4d3..80086b76 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -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)" diff --git a/plans/composition-objects.md b/plans/composition-objects.md index f106cde6..809e99fa 100644 --- a/plans/composition-objects.md +++ b/plans/composition-objects.md @@ -106,9 +106,18 @@ Transclusion = a `ref` leaf. Sort/filter/limit/group = the *source query* langua self-contained — it asks the context for the data; the host supplies graph access. The list isn't baked into the body; it's whatever is-a TYPE *right now*. (`/compose-demo` each is now a live query over seeded `compose-item` instances.) -4. Live context: route auth/device/locale into the context; reactive values later. -5. The typed importer decomposes Ghost Lexical into card objects + a `contains` body (cards-as- - objects), instead of one `sx_content` string. +4. **(done)** Live context: `host/blog--comp-ctx` routes auth + device (User-Agent) + locale + (Accept-Language) — read purely from the request — into the render context, so the SAME + object renders a responsive/personalised variant (`(alt (when (eq "device" "mobile") …) …)`). + Reactive values plug into the same context later with no new combinators. +5. **(done)** The typed importer decomposes content into card OBJECTS + a `contains` body + (cards-as-objects), instead of one `sx_content` string. `host/blog--decompose!` splits an + `(article …)` into one stored card object per block (is-a a card-type + field-values), + linked by ordered `contains` edges, with `:body = (seq (ref c0) (ref c1) …)`. Card types + carry a render `:template`, so the `ref` combinator transcludes each card via the existing + typed-block path. `/import` wired; home filtered to published so `"block"` cards stay hidden. + The `val` (raw value) leaf added for attribute interpolation. (Perf: typing now reads direct + KV `subtype-of` edges via a host-side BFS, not lib/relations — no Datalog re-saturation.) 6. The block editor edits the body (insert/reorder/`alt`/`each`) — the metamodel editor for content. 7. **Prove universality with a second fold.** Write a tiny `execute`-fold over the *same* `seq/alt/each` structure that *runs* a workflow (leaves = effects; `seq` = steps in order, `alt`