host: relations-as-posts slice 1 — declaration-driven candidate pools
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 42s

Types declare which relation they anchor (type declares is-a/subtype-of, tag
declares tagged) via a 'declares' edge; the picker's candidate set is the
down-closure of a relation's anchors through is-a ∪ subtype-of. So is-a/subtype-of
now offer the WHOLE type closure — the roots (type/tag/article) AND instances —
fixing the wrinkle where only instances showed and you could never pick 'tag' or
'article' as a type. 'related' has no anchor → every post.

Replaces the hardcoded :candidates "types"/"tags"/"all" with graph queries
(host/blog--reach-down + the declares edges). Design + roadmap (relations as
first-class posts, typed relations, type algebra, constraints) in
plans/relations-as-posts.md.

host conformance 283/283 (+5: is-a pool includes type roots, excludes plain posts,
tagged anchored by tag, related = all, is-a relate-options offers Article).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
2026-06-29 21:40:27 +00:00
parent ad556c3e31
commit b3804ce712
3 changed files with 142 additions and 10 deletions

View File

@@ -322,27 +322,55 @@
(host/blog-seed! "article" "Article"
"(article (h1 \"Article\") (p \"A kind of post that must have a heading. A post that is-a article is checked against this type's schema on save — gradual typing: declaring the type adds the requirement, and the next edit must satisfy it.\"))"
"published")
(host/blog-relate! "article" "type" "subtype-of"))))
(host/blog-relate! "article" "type" "subtype-of")
;; 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
;; type graph, so the candidates for a relation are exactly the posts that inherit
;; its declaration. `type` anchors is-a + subtype-of (you point at a type), `tag`
;; anchors tagged (you point at a tag). `related` has no anchor → every post.
(host/blog-relate! "type" "is-a" "declares")
(host/blog-relate! "type" "subtype-of" "declares")
(host/blog-relate! "tag" "tagged" "declares"))))
;; ── relate picker (filterable, paginated candidate list) ────────────
;; Candidates to relate `slug` to: every post except itself and ones already
;; related, narrowed by `q` (case-insensitive substring of title or slug),
;; title-sorted. One page is `host/blog--picker-limit` rows from `offset`.
(define host/blog--picker-limit 20)
;; The candidate POOL for a kind comes from its registry :candidates: "all" posts,
;; or the members of a type ("tags" = instances of tag, "types" = instances of
;; type). Enumerating a type's members is O(#subtypes), not O(#posts).
;; Down-closure: every post reachable from `roots` by walking INVERSE is-a
;; subtype-of edges (i.e. instances and subtypes, transitively), roots included.
;; This is "everything that is, transitively, an instance-or-subtype of a root".
;; BFS over direct edges (host/blog-in); `seen` makes it cycle-safe and terminating.
(define host/blog--reach-down
(fn (roots)
(let loop ((frontier roots) (seen (list)))
(if (empty? frontier)
seen
(let ((t (first frontier)))
(if (contains? seen t)
(loop (rest frontier) seen)
(loop
(concat (rest frontier)
(concat (host/blog-in t "is-a") (host/blog-in t "subtype-of")))
(concat seen (list t)))))))))
;; The candidate POOL for relating under `kind` is DECLARATION-driven (see
;; plans/relations-as-posts.md): the down-closure of the posts that DECLARE `kind`
;; at their object end. So is-a/subtype-of (anchored by `type`) offer the whole type
;; closure — roots AND instances — and `tagged` (anchored by `tag`) offers the tags.
;; A relation with no declaration (e.g. `related`) offers every post.
(define host/blog--candidate-pool
(fn (candidates)
(cond
((= candidates "tags") (host/blog-instances-of "tag"))
((= candidates "types") (host/blog-instances-of "type"))
(else (host/blog-slugs)))))
(fn (kind)
(let ((anchors (host/blog-in kind "declares")))
(if (empty? anchors)
(host/blog-slugs)
(host/blog--reach-down anchors)))))
(define host/blog--relate-candidates
(fn (slug q kind)
(let ((spec (host/blog--kind-spec kind)))
(let ((pool (host/blog--candidate-pool (get spec :candidates)))
(let ((pool (host/blog--candidate-pool kind))
(already (host/blog-out slug kind))
(ql (lower (or q ""))))
;; pool is slugs; resolve titles, drop self + already-linked, filter by q

View File

@@ -457,6 +457,30 @@
(host-bl-test "type-valid? is vacuously true with no schemas (gradual)"
(host/blog-type-valid? "ppost" "(p \"anything\")") true)
;; -- relations-as-posts: declaration-driven candidate pools (plans/relations-as-posts.md) --
;; The picker's candidate set is the down-closure of a relation's anchors. is-a/subtype-of
;; are anchored by `type`, so they offer the WHOLE type closure — the roots (type/tag/
;; article) AND the instances — fixing the wrinkle where only instances showed.
(host-bl-test "is-a candidates = the type closure: roots (type/tag/article) AND instances"
(let ((pool (host/blog--candidate-pool "is-a")))
(list (contains? pool "type") (contains? pool "tag")
(contains? pool "article") (contains? pool "ocaml"))) ;; ocaml is-a tag
(list true true true true))
(host-bl-test "is-a candidates exclude a plain content post (not is-a/subtype-reachable to Type)"
(contains? (host/blog--candidate-pool "is-a") "ppost") false)
(host-bl-test "tagged candidates are anchored by tag (tag + its instances)"
(let ((pool (host/blog--candidate-pool "tagged")))
(list (contains? pool "tag") (contains? pool "ocaml")))
(list true true))
(host-bl-test "related candidates = every post (no declaration anchors it)"
(let ((pool (host/blog--candidate-pool "related")))
(list (contains? pool "type") (contains? pool "ppost")))
(list true true))
;; and it flows through to the live picker endpoint: the is-a picker now offers a type root
(host-bl-test "is-a relate-options offers the type roots (Article)"
(contains? (dream-resp-body (host-bl-app (host-bl-req "/ppost/relate-options?kind=is-a"))) "Article")
true)
;; -- Phase 3: tags as posts -- (ocaml is-a tag, from the seed-types test above)
(host-bl-test "is-tag?: a post that is-a tag is a tag; others are not"
(list (host/blog-is-tag? "ocaml") (host/blog-is-tag? "ppost"))