host: typed relations — Phase 2, type resolution with subsumption
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 <noreply@anthropic.com>
This commit is contained in:
@@ -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 "/")))
|
||||
|
||||
Reference in New Issue
Block a user