From cb2fc788d783a8609518e0344f7561de5634ffd2 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 28 Jun 2026 16:49:00 +0000 Subject: [PATCH] =?UTF-8?q?host:=20typed=20relations=20=E2=80=94=20Phase?= =?UTF-8?q?=202,=20type=20resolution=20with=20subsumption?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The spine: types ARE posts, and typing is transitive the right way. is-a (instance-of) does NOT chain on its own, but subsumption does — an instance of a subtype is an instance of the supertype. - registry gains "subtype-of" (directed, transitive). host/blog-types-of(slug) = declared is-a targets PLUS every subtype-of-ancestor of each (composed host-side over relations/descendants — no new Datalog rules). host/blog-is-a?(slug,type) is transitive through subtype-of. - host/blog-seed-types! seeds the root type-posts "type" and "tag" (real posts that document themselves) with tag subtype-of type, so anything is-a tag is transitively a type. Idempotent; wired into serve.sh. - gradual-validation seam: host/blog-type-schemas (empty) + host/blog-schema-of + host/blog-type-valid? (vacuously true with no schemas) wired into edit-submit alongside the parse check — enforcement is a one-line add later, not a retrofit. 6 tests: types-of = declared + all subtype-of supertypes; is-a? transitive through subtype-of; is-a alone does NOT chain; instance of tag is transitively a type; type-valid vacuous with no schemas. 255/255. Verified live: /type/ + /tag/ render as posts, tag subtype-of type survived a recreate (durable), ocaml is-a tag. Co-Authored-By: Claude Opus 4.8 --- lib/host/blog.sx | 61 +++++++++++++++++++++++++++++++++++++++++- lib/host/serve.sh | 4 +++ lib/host/tests/blog.sx | 36 +++++++++++++++++++++++++ 3 files changed, 100 insertions(+), 1 deletion(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 5e594eaf..55134566 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -99,6 +99,8 @@ {:kind "related" :label "Related posts" :symmetric true :candidates "all"} {:kind "is-a" :label "Types" :symmetric false :candidates "types" :inverse-label "Instances"} + {:kind "subtype-of" :label "Subtype of" :symmetric false :candidates "types" + :inverse-label "Subtypes"} {:kind "tagged" :label "Tags" :symmetric false :candidates "tags" :inverse-label "Tagged with this"})) @@ -184,6 +186,60 @@ ;; back-compat: "related posts" is just the symmetric "related" kind. (define host/blog-related (fn (slug) (host/blog-out slug "related"))) +;; ── typing: is-a + subtype-of with subsumption ────────────────────── +;; Typing is just relating to a type, and types ARE posts. A post DECLARES its +;; 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. +(define host/blog--uniq + (fn (xs) (reduce (fn (acc x) (if (contains? acc x) acc (concat acc (list x)))) (list) xs))) + +(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"))))) + +;; is this post (transitively) of the given type-slug? +(define host/blog-is-a? (fn (slug type) (contains? (host/blog-types-of slug) type))) + +;; ── gradual validation seam ───────────────────────────────────────── +;; A type-post optionally carries a schema: a predicate over content. The map is +;; empty for now — validation is gradual, types accrue schemas later — but the +;; hook lives here so enforcement is a one-line addition, never a retrofit. A post +;; is type-valid when every schema implied by its types accepts the content; with +;; no schemas this is vacuously true, so it costs nothing until a type opts in. +(define host/blog-type-schemas {}) +(define host/blog-schema-of (fn (type-slug) (get host/blog-type-schemas type-slug))) +(define host/blog-type-valid? + (fn (slug content) + (every? + (fn (t) (let ((s (host/blog-schema-of t))) (or (nil? s) (s content)))) + (host/blog-types-of slug)))) + +;; 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 +;; type means anything that is-a tag is, transitively, a type. Idempotent — safe +;; to call on every boot (host/blog-seed! no-ops if present, edges are sets). +(define host/blog-seed-types! + (fn () + (begin + (host/blog-seed! "type" "Type" + "(article (h1 \"Type\") (p \"The root type. Types are posts — so this is a post that documents the idea of a type. A post declares its types with is-a edges; types form a hierarchy with subtype-of edges.\"))" + "published") + (host/blog-seed! "tag" "Tag" + "(article (h1 \"Tag\") (p \"A tag is a kind of type (tag subtype-of type), so anything that is-a tag is also a type. A post is tagged with a tag; a tag post documents the tag and lists what is tagged with it.\"))" + "published") + (host/blog-relate! "tag" "type" "subtype-of")))) + ;; ── 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), @@ -604,7 +660,10 @@ (let ((title (or (dream-form-field req "title") (get r :title))) (sx-content (or (dream-form-field req "sx_content") "")) (status (or (dream-form-field req "status") (get r :status)))) - (if (host/blog-content-ok? sx-content) + ;; parse-valid AND type-valid (the post's types' schemas accept the + ;; content — vacuous until a type opts into a schema). + (if (and (host/blog-content-ok? sx-content) + (host/blog-type-valid? slug sx-content)) (begin (host/blog-put! slug title sx-content status) (dream-redirect (str "/" slug "/"))) diff --git a/lib/host/serve.sh b/lib/host/serve.sh index 1259d18b..b2a1090d 100755 --- a/lib/host/serve.sh +++ b/lib/host/serve.sh @@ -137,6 +137,10 @@ EPOCH=1 echo "(epoch $EPOCH)" echo "(eval \"(host/blog-seed! \\\"welcome\\\" \\\"Welcome to the SX host\\\" \\\"(article (h1 \\\\\\\"Welcome to the SX host\\\\\\\") (p \\\\\\\"Rendered by lib/host via render-to-html, from the durable SX store.\\\\\\\"))\\\" \\\"published\\\")\")" EPOCH=$((EPOCH+1)) + # Seed the root type-posts (type, tag) — types ARE posts. Idempotent. + echo "(epoch $EPOCH)" + echo "(eval \"(host/blog-seed-types!)\")" + EPOCH=$((EPOCH+1)) echo "(epoch $EPOCH)" # Anonymous reads (feed timeline + relations container reads + blog post detail) # plus the GUARDED blog write routes: POST /new (editor form ingest), POST/PUT/ diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index da364f7a..6b8f0f16 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -333,6 +333,42 @@ (persist/backend-kv-has? host/blog-store (host/blog--edge-key "alpha-post" "tagged" "gamma-post"))) false) +;; -- Phase 2: typing with subsumption (is-a + subtype-of) -- +;; ppost --is-a--> ptutorial ; ptutorial --subtype-of--> particle --subtype-of--> pdoc +(host/blog-put! "ptutorial" "P Tutorial" "(p \"t\")" "published") +(host/blog-put! "particle" "P Article" "(p \"a\")" "published") +(host/blog-put! "pdoc" "P Doc" "(p \"d\")" "published") +(host/blog-put! "ppost" "P Post" "(p \"p\")" "published") +(host/blog-relate! "ptutorial" "particle" "subtype-of") +(host/blog-relate! "particle" "pdoc" "subtype-of") +(host/blog-relate! "ppost" "ptutorial" "is-a") +(host-bl-test "types-of = declared type + ALL its subtype-of supertypes" + (list (contains? (host/blog-types-of "ppost") "ptutorial") + (contains? (host/blog-types-of "ppost") "particle") + (contains? (host/blog-types-of "ppost") "pdoc")) + (list true true true)) +(host-bl-test "is-a? is transitive THROUGH subtype-of (subsumption)" + (list (host/blog-is-a? "ppost" "ptutorial") + (host/blog-is-a? "ppost" "pdoc")) + (list true true)) +(host-bl-test "is-a? alone does NOT chain (instance-of is not transitive)" + (begin + (host/blog-put! "pmeta" "P Meta" "(p \"m\")" "published") + (host/blog-relate! "pmeta" "ppost" "is-a") ;; pmeta is-a ppost is-a ptutorial + (host/blog-is-a? "pmeta" "ptutorial")) ;; ... does NOT make pmeta is-a ptutorial + false) +(host-bl-test "is-a? false for an unrelated type" + (host/blog-is-a? "ppost" "particle") true) ;; sanity: this one IS reachable +(host-bl-test "seed-types: an instance of tag is, transitively, a type" + (begin + (host/blog-seed-types!) ;; type, tag, tag subtype-of type + (host/blog-put! "ocaml" "OCaml" "(p \"lang\")" "published") + (host/blog-relate! "ocaml" "tag" "is-a") ;; ocaml is-a tag + (list (host/blog-is-a? "ocaml" "tag") (host/blog-is-a? "ocaml" "type"))) + (list true true)) +(host-bl-test "type-valid? is vacuously true with no schemas (gradual)" + (host/blog-type-valid? "ppost" "(p \"anything\")") 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))