host: typed relations — Phase 1, generalize edges to carry a kind

Plan: plans/typed-posts-and-relations.md. "Typing is just relating to a type",
types are posts. Phase 1 lifts the hard-coded kind:"related" into a parameter,
driven by one registry — the spine the later phases (type resolution, tags,
picker) build on. Zero user-visible change.

- host/blog-rel-kinds registry: {kind,label,symmetric,candidates[,inverse-label]}
  for related (symmetric) / is-a / tagged (directed). One place knows each kind's
  direction, label, and candidate set.
- host/blog-relate!/unrelate! take a kind; symmetric kinds write both directions,
  directed kinds write one. host/blog-out/in read children/parents per kind;
  host/blog-related = out(slug,"related") (back-compat).
- relate/unrelate routes carry a `kind` form field (default "related"), validated
  against the registry. delete drops edges across ALL kinds + both directions.

6 tests: symmetric reads both sides, directed writes one (inverse via host/blog-in),
unrelate is kind-scoped, unknown kind rejected, default kind = related. 244/244;
Playwright picker 4/4 (related path unchanged).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>

lib/host/blog.sx

@@ -85,35 +85,68 @@
             (else (host/blog--render-node tree))))
         (str "<p>(empty post)</p>")))))
 ;; ── related posts (blog × relations) ────────────────────────────────
-;; A "related" link between two posts is a SYMMETRIC pair of edges in the
+;; Every link between posts is a typed edge in the relations graph (lib/relations):
-;; relations graph (lib/relations): node = "blog:<slug>", kind = related. Edges go
+;; node = "blog:<slug>", kind = a relation kind. "related" is symmetric; directed
-;; both ways so "related posts" reads the same from either side via children alone
+;; kinds (is-a, tagged) carry meaning by direction. The registry below is the one
-;; — composing two already-migrated domains (blog + relations) on the host.
+;; place that knows each kind's direction, label, and candidate set — relate, the
-(define host/blog--rel-kind (string->symbol "related"))
+;; picker, and rendering all read from it (see plans/typed-posts-and-relations.md).
+;; "Typing is just relating to a type": classification is an is-a/tagged edge to a
+;; type-post, and types ARE posts (same blog:<slug> namespace).
 (define host/blog--node (fn (slug) (string->symbol (str "blog:" slug))))
 
-(define host/blog-relate!
+(define host/blog-rel-kinds
-  (fn (a b)
+  (list
-    (begin
+    {:kind "related" :label "Related posts" :symmetric true :candidates "all"}
-      (relations/relate (host/blog--node a) (host/blog--node b) host/blog--rel-kind)
+    {:kind "is-a" :label "Types" :symmetric false :candidates "types"
-      (relations/relate (host/blog--node b) (host/blog--node a) host/blog--rel-kind))))
+                  :inverse-label "Instances"}
-(define host/blog-unrelate!
+    {:kind "tagged" :label "Tags" :symmetric false :candidates "tags"
-  (fn (a b)
+                    :inverse-label "Tagged with this"}))
-    (begin
-      (relations/unrelate (host/blog--node a) (host/blog--node b) host/blog--rel-kind)
-      (relations/unrelate (host/blog--node b) (host/blog--node a) host/blog--rel-kind))))
 
-;; related slugs for a post: blog children under "related", stripped to slug, and
+;; registry lookup; nil for an unknown kind (relate validates against this)
-;; limited to posts that still exist (a deleted post can leave a dangling edge).
+(define host/blog--kind-spec
-;; Existence is checked against ONE kv-keys read (host/blog-slugs), not a perform
+  (fn (kind)
-;; per candidate — keeping IO out of the inner filter.
+    (reduce (fn (acc k) (if (= (get k :kind) kind) k acc)) nil host/blog-rel-kinds)))
-(define host/blog-related
+(define host/blog--kind-symmetric?
-  (fn (slug)
+  (fn (kind) (let ((s (host/blog--kind-spec kind))) (and s (get s :symmetric)))))
+
+;; ── edges (parameterised by kind) ───────────────────────────────────
+;; A symmetric kind writes both directions, so children alone read it from either
+;; side; a directed kind writes one edge (the inverse is host/blog-in).
+(define host/blog-relate!
+  (fn (a b kind)
+    (let ((k (string->symbol kind)))
+      (begin
+        (relations/relate (host/blog--node a) (host/blog--node b) k)
+        (when (host/blog--kind-symmetric? kind)
+          (relations/relate (host/blog--node b) (host/blog--node a) k))))))
+(define host/blog-unrelate!
+  (fn (a b kind)
+    (let ((k (string->symbol kind)))
+      (begin
+        (relations/unrelate (host/blog--node a) (host/blog--node b) k)
+        (when (host/blog--kind-symmetric? kind)
+          (relations/unrelate (host/blog--node b) (host/blog--node a) k))))))
+
+;; nodes -> existing blog slugs: strip "blog:", drop non-blog and deleted targets.
+;; Existence is one kv-keys read (host/blog-slugs), NOT a perform per candidate —
+;; keeping IO out of the inner filter (and out of the page-render quasiquote).
+(define host/blog--edge-slugs
+  (fn (nodes)
     (let ((existing (host/blog-slugs)))
-      (let ((kids (relations/children (host/blog--node slug) host/blog--rel-kind)))
       (filter (fn (s) (contains? existing s))
         (map (fn (n) (substr (symbol->string n) 5))
-            (filter (fn (n) (starts-with? (symbol->string n) "blog:")) kids)))))))
+          (filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))
+
+;; outgoing targets / incoming sources of `slug` under `kind`, as slug lists.
+(define host/blog-out
+  (fn (slug kind)
+    (host/blog--edge-slugs (relations/children (host/blog--node slug) (string->symbol kind)))))
+(define host/blog-in
+  (fn (slug kind)
+    (host/blog--edge-slugs (relations/parents (host/blog--node slug) (string->symbol kind)))))
+
+;; back-compat: "related posts" is just the symmetric "related" kind.
+(define host/blog-related (fn (slug) (host/blog-out slug "related")))
 
 ;; ── relate picker (filterable, paginated candidate list) ────────────
 ;; Candidates to relate `slug` to: every post except itself and ones already
@@ -421,42 +454,57 @@
         (host/error 400 "invalid payload")))))
 
 ;; DELETE /posts/<slug>
+;; drop every edge touching `slug`, across all kinds + both directions, so a
+;; deleted post leaves no dangling links anywhere in the graph.
+(define host/blog--drop-all-edges!
+  (fn (slug)
+    (for-each
+      (fn (spec)
+        (let ((kind (get spec :kind)))
+          (begin
+            (for-each (fn (o) (host/blog-unrelate! slug o kind)) (host/blog-out slug kind))
+            (for-each (fn (o) (host/blog-unrelate! o slug kind)) (host/blog-in slug kind)))))
+      host/blog-rel-kinds)))
+
 (define host/blog-delete-handler
   (fn (req)
     (let ((slug (dream-param req "slug")))
       (if (host/blog-exists? slug)
         (begin
-          ;; drop the post's related edges so no dangling links survive it
+          (host/blog--drop-all-edges! slug)
-          (for-each (fn (o) (host/blog-unrelate! slug o)) (host/blog-related slug))
           (host/blog-delete! slug)
           (host/ok {:slug slug :deleted true}))
         (host/error 404 "no such post")))))
 
-;; POST /<slug>/relate — relate this post to another (form field `other` = slug).
+;; POST /<slug>/relate — relate this post to another (form `other` = slug, `kind` =
-;; Validated: the other post must exist and differ; otherwise it's a no-op. Always
+;; relation kind, default "related"). Validated: kind must be a known kind and the
-;; redirects back to the edit page. Guarded like the other browser write routes.
+;; other post must exist and differ; otherwise a no-op. Redirects back to the edit
+;; page. Guarded like the other browser write routes.
 (define host/blog-relate-submit
   (fn (req)
     (let ((slug (dream-param req "slug"))
-          (other (dream-form-field req "other")))
+          (other (dream-form-field req "other"))
+          (kind (or (dream-form-field req "kind") "related")))
       (if (nil? (host/blog-get slug))
         (dream-html-status 404
           (host/blog--page "Not found"
             (quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
         (begin
-          (when (and other (not (= other "")) (not (= other slug)) (host/blog-exists? other))
+          (when (and other (not (= other "")) (not (= other slug))
-            (host/blog-relate! slug other))
+                     (host/blog--kind-spec kind) (host/blog-exists? other))
+            (host/blog-relate! slug other kind))
           (dream-redirect (str "/" slug "/edit")))))))
 
-;; POST /<slug>/unrelate — remove the relation to `other`. Idempotent; redirects
+;; POST /<slug>/unrelate — remove the relation to `other` under `kind` (default
-;; back to the edit page.
+;; "related"). Idempotent; redirects back to the edit page.
 (define host/blog-unrelate-submit
   (fn (req)
     (let ((slug (dream-param req "slug"))
-          (other (dream-form-field req "other")))
+          (other (dream-form-field req "other"))
+          (kind (or (dream-form-field req "kind") "related")))
       (begin
-        (when (and other (not (= other "")))
+        (when (and other (not (= other "")) (host/blog--kind-spec kind))
-          (host/blog-unrelate! slug other))
+          (host/blog-unrelate! slug other kind))
         (dream-redirect (str "/" slug "/edit"))))))
 
 ;; GET /<slug>/edit — edit form pre-filled with the post's current title, raw

lib/host/tests/blog.sx

@@ -267,10 +267,10 @@
   (list true false))
 (host-bl-test "relate-options excludes already-related candidates"
   (begin
-    (host/blog-relate! "alpha-post" "beta-post")
+    (host/blog-relate! "alpha-post" "beta-post" "related")
     (contains? (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options"))) "Beta Post"))
   false)
-(host/blog-unrelate! "alpha-post" "beta-post")
+(host/blog-unrelate! "alpha-post" "beta-post" "related")
 (host-bl-test "relate-picker.js served as javascript"
   (dream-resp-header (host-bl-app (host-bl-req "/relate-picker.js")) "content-type")
   "application/javascript; charset=utf-8")
@@ -281,6 +281,40 @@
 (host-bl-test "related block: empty when anonymous + no relations"
   (= (host/blog--related-block "gamma-post" false) "") true)
 
+;; -- Phase 1: relations carry a kind --
+(host-bl-test "symmetric kind (related) reads from both sides"
+  (begin
+    (host/blog-relate! "alpha-post" "gamma-post" "related")
+    (list (contains? (host/blog-out "alpha-post" "related") "gamma-post")
+          (contains? (host/blog-out "gamma-post" "related") "alpha-post")))
+  (list true true))
+(host-bl-test "directed kind (tagged) writes one direction; inverse via host/blog-in"
+  (begin
+    (host/blog-relate! "alpha-post" "beta-post" "tagged")
+    (list (contains? (host/blog-out "alpha-post" "tagged") "beta-post")
+          (contains? (host/blog-out "beta-post" "tagged") "alpha-post")
+          (contains? (host/blog-in "beta-post" "tagged") "alpha-post")))
+  (list true false true))
+(host-bl-test "unrelate is kind-scoped (related edge survives a tagged unrelate)"
+  (begin
+    (host/blog-unrelate! "alpha-post" "beta-post" "tagged")
+    (list (contains? (host/blog-out "alpha-post" "tagged") "beta-post")
+          (contains? (host/blog-out "alpha-post" "related") "gamma-post")))
+  (list false true))
+(host/blog-unrelate! "alpha-post" "gamma-post" "related")
+(host-bl-test "relate-submit rejects an unknown kind (no-op)"
+  (begin
+    (host-bl-wapp (host-bl-send "POST" "/alpha-post/relate" "Bearer good"
+      "application/x-www-form-urlencoded" "other=beta-post&kind=bogus"))
+    (contains? (host/blog-out "alpha-post" "bogus") "beta-post"))
+  false)
+(host-bl-test "default kind is related (no kind field)"
+  (begin
+    (host-bl-wapp (host-bl-send "POST" "/alpha-post/relate" "Bearer good"
+      "application/x-www-form-urlencoded" "other=beta-post"))
+    (contains? (host/blog-out "alpha-post" "related") "beta-post"))
+  true)
+
 ;; -- experimental unguarded create-only route (POST /new, no auth) --
 (define host-bl-oapp (host/make-app (list host/blog-open-create-routes host/blog-routes)))
 (host/blog-use-store! (persist/open))

plans/typed-posts-and-relations.md

@@ -0,0 +1,96 @@
+# Typed posts & relations — typing is just relating to a type
+
+> host-on-sx. Driving idea: **classification is a relation to a type node, and
+> types are posts.** Everything (related, tag, category, series, type) becomes a
+> typed edge in `lib/relations` over `blog:<slug>` nodes. One primitive.
+
+## Decisions
+
+- **Types are posts.** No new node namespace — content-posts and type/tag posts
+  are all `blog:<slug>`. A "tag" is a post; tagging documents itself.
+- **`is-a` is the typing edge; `tagged` is membership.** Kept distinct so a tag
+  page can list members without conflating "ocaml is a tag" with "hello is
+  tagged ocaml".
+- **Hierarchy is core, not deferred.** `is-a`/`subtype-of` transitive closure via
+  `lib/relations` reachability is what makes typing-as-relation more than flat
+  labels. All typing helpers are transitive from the first line, or subtypes
+  silently break candidate/`is-a?` checks later.
+- **Validation is gradual, not deferred.** A type-post *optionally* carries a
+  schema slot; validation runs only where one exists. Tags declare none (stay
+  folksonomy-free); `article` can declare "needs a heading". The hook lands with
+  the type phase (reusing `host/blog-content-ok?`); only schema *expressiveness*
+  grows over time. This closes the nominal/structural loop: the declared `is-a`
+  edge is a claim, the validator checks the content honors it.
+- **Scalars stay fields.** `status`/`title`/`sx_content` remain fields, not edges
+  — listings filter on them constantly and `lib/relations` re-saturates Datalog
+  per query. Links-to-shared-nodes → edges; per-post hot scalars → fields.
+
+## The linchpin: a relation-kind registry
+
+One data structure drives validation, the picker candidate sets, and rendering:
+
+```
+host/blog-rel-kinds =
+  ({:kind "related" :label "Related posts" :symmetric true  :candidates "all"}
+   {:kind "is-a"    :label "Types"         :symmetric false :candidates "types"
+                    :inverse-label "Instances"}
+   {:kind "tagged"  :label "Tags"          :symmetric false :candidates "tags"
+                    :inverse-label "Tagged with this"})
+```
+
+`:symmetric` → write both directions on relate. `:candidates` → what the picker
+offers (`all` = every post; `tags` = `is-a? blog:tag` transitively; `types` =
+`is-a? blog:type`). `:label`/`:inverse-label` → headings.
+
+## Phases
+
+### Phase 1 — Kind generalization + registry  ← START HERE
+Pure refactor; zero user-visible change (related keeps working).
+- `host/blog-rel-kinds` registry + `host/blog--kind-spec`/`--kind-symmetric?`.
+- `host/blog-relate!(a,b,kind)` / `unrelate!(a,b,kind)` — directed; symmetric kinds
+  also write the reverse (today's "related" behavior = the symmetric case).
+- `host/blog-out(slug,kind)` (children) / `host/blog-in(slug,kind)` (parents),
+  existence-filtered. `host/blog-related(slug)` = `out(slug,"related")` (back-compat).
+- Routes carry `kind` (form field, default `"related"`); validated against registry.
+- `delete` cleanup drops edges across **all** kinds, both directions.
+
+### Phase 2 — Type resolution via reachability (the spine)
+- Seed root type-posts: `blog:type` ("Type") and `blog:tag is-a blog:type`,
+  each documenting itself. Idempotent seed in `serve.sh`.
+- `host/blog-types-of(slug)` = direct `is-a` targets ∪ `subtype-of`-reach of each
+  (SX-side composition over `lib/relations` reach — no new Datalog rules).
+- `host/blog-is-a?(slug, type)` — **transitive**.
+- Type-posts carry an optional `:schema` slot (designed now, mostly empty).
+- Validation hook: `host/blog-content-ok?` extended to also run any schema(s)
+  implied by the post's declared types. No schema → no-op (gradual).
+
+### Phase 3 — Tags as posts
+- "is a tag" = `host/blog-is-a? slug "tag"` (transitive). Helpers
+  `host/blog-tags(slug)` = `out(slug,"tagged")`, `host/blog-tagged-with(tag)` =
+  `in(tag,"tagged")`.
+- Edit page: a "This post is a tag" toggle = add/remove `is-a blog:tag` edge.
+
+### Phase 4 — Render (data-driven from the registry)
+- Post page iterates the registry → "Related posts" + "Tags" blocks, same code.
+- Tag-post page: its own content (the tag's documentation) **plus** "Tagged with
+  this" (incoming `tagged`). A tag page documents the tag AND lists its members.
+- Optional `/tags` index = posts `is-a? blog:tag`.
+
+### Phase 5 — Generalize the picker
+- `host/blog--relate-candidates(slug, q, kind)` branches on the kind's
+  `:candidates` (all / tags / types).
+- `relate-options` endpoint takes `&kind=`; picker filter input carries
+  `data-kind`; `relate-picker.js` forwards it.
+- Edit page renders one picker section per kind from the registry.
+
+### Phase 6 — Schema expressiveness (ongoing)
+- Grow the type `:schema` language: start minimal (required block kinds / a
+  predicate over content), richer later. Enforcement already wired in Phase 2;
+  only the language grows. Not a blocker — a gradient.
+
+## Notes
+- Node model unchanged (`blog:<slug>`); only `kind` varies. The relate machinery,
+  picker, and post-page block all generalize by lifting the hard-coded
+  `kind: "related"` into a parameter.
+- A type can *be* a post all the way up (`blog:tag is-a blog:type`); meta-circular
+  but bounded by seeding a small root set.