From 7b9aece52d220269fd086c3e064eb3dafd76b648 Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 30 Jun 2026 11:38:58 +0000 Subject: [PATCH] =?UTF-8?q?host:=20metamodel=20overview=20page=20(GET=20/m?= =?UTF-8?q?eta)=20=E2=80=94=20the=20first=20editor=20surface?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The 'see the system you've defined' page: every type-post (with its schema's required blocks) and every relation-post (with its signature), each linking to the post that defines it. The surface the metamodel editor hangs off (North Star UI surface 1 of 3). - host/blog-type-defs: the type DEFINITIONS = the subtype-of hierarchy rooted at 'type' (type + transitive subtypes). NOT host/blog-instances-of 'type' (that's the is-a INSTANCES — typed content, not the definitions, which are linked by subtype-of). - host/blog-meta-index (GET /meta, mounted before /:slug): pure read, all durable reads pre-fetched into let bindings before the quasiquote (perform-in-tree = VmSuspend); relations from the boot-populated host/blog-rel-kinds VALUE. Types + relations tables. - Home footer links to /meta + /tags. Verified live (ephemeral): Types (3: Type/Tag/Article, Article shows required block h1), Relations (4: related symmetric, is-a/subtype-of/tagged directed). Blog suite 122/122. Co-Authored-By: Claude Opus 4.8 --- lib/host/blog.sx | 72 +++++++++++++++++++++++++++++++++++++++++- lib/host/tests/blog.sx | 14 ++++++++ 2 files changed, 85 insertions(+), 1 deletion(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index ab6db4f8..38ce2527 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -330,6 +330,18 @@ (host/blog--uniq (reduce (fn (acc t) (concat acc (host/blog-in t "is-a"))) (list) subtypes))))) +;; 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. +(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"))))))) + ;; ── Slice 4: type ALGEBRA — intersection (∧) and union (∨) types ───── ;; An algebraic type is a post with operand edges: a `conj` edge per intersection ;; member, a `disj` edge per union member. Its EXTENT is its operands' extents combined @@ -960,7 +972,8 @@ (unquote listing) (p (a :href "/new" "+ New post")) (p :style "margin-top:2em;font-size:0.9em;opacity:0.8" - (unquote auth-foot))))))))))) + (a :href "/meta" "metamodel") " · " (a :href "/tags" "tags") + " · " (unquote auth-foot))))))))))) (define host/blog-index (fn (req) (host/ok (host/blog-list)))) @@ -988,6 +1001,62 @@ (p :style "margin-top:2em;font-size:0.9em;opacity:0.8" (a :href "/" "all posts") " · " (unquote auth-foot)))))))))) +;; ── metamodel overview (GET /meta) ───────────────────────────────── +;; The "see the system you've defined" page: every type-post (with its schema's +;; required blocks) and every relation-post (with its signature). Types + relations +;; are themselves posts, so each row links to the post that defines it. Pure read; +;; durable reads pre-fetched into let bindings BEFORE the quasiquote (a perform during +;; tree-build raises VmSuspended), and relations come from the boot-populated +;; host/blog-rel-kinds VALUE (no perform). The surface the metamodel editor hangs off. +(define host/blog--schema-summary + (fn (schema) + (if (and schema (> (len schema) 0)) + (join ", " (map (fn (rule) (get rule :block)) schema)) + "—"))) +(define host/blog-meta-index + (fn (req) + (let ((type-recs + (map (fn (s) {:slug s + :title (get (host/blog-get s) :title) + :schema (host/blog-schema-of s)}) + (sort (host/blog-type-defs)))) + (rel-specs host/blog-rel-kinds) + (auth-foot (host/auth-footer req))) + (let ((type-rows + (map (fn (p) + (quasiquote + (tr (td (a :href (unquote (str "/" (get p :slug) "/")) + (unquote (get p :title)))) + (td (unquote (host/blog--schema-summary (get p :schema))))))) + type-recs)) + (rel-rows + (map (fn (spec) + (quasiquote + (tr (td (unquote (get spec :kind))) + (td (unquote (or (get spec :label) ""))) + (td (unquote (if (get spec :symmetric) "symmetric" "directed"))) + (td (unquote (or (get spec :inverse-label) "—")))))) + rel-specs))) + (host/blog--resp req 200 + (host/blog--page req "Metamodel" + (quasiquote + (div + (h1 "Metamodel") + (p "The types and relations that define this system. Each is itself a post — click through to its definition.") + (h2 (unquote (str "Types (" (len type-recs) ")"))) + (unquote (if (> (len type-recs) 0) + (cons (quote table) + (cons (quote (tr (th "Type") (th "Required blocks"))) type-rows)) + (quote (p "No types yet.")))) + (h2 (unquote (str "Relations (" (len rel-specs) ")"))) + (unquote (if (> (len rel-specs) 0) + (cons (quote table) + (cons (quote (tr (th "Relation") (th "Label") (th "Kind") (th "Inverse"))) rel-rows)) + (quote (p "No relations yet.")))) + (p :style "margin-top:2em;font-size:0.9em;opacity:0.8" + (a :href "/" "all posts") " · " (a :href "/tags" "tags") + " · " (unquote auth-foot)))))))))) + ;; GET //source — the raw sx_content as text/plain. Posts ARE SX source, so ;; this just hands back the stored markup (public; a published post's source is ;; not secret). 404 if the post is absent. @@ -1206,6 +1275,7 @@ (dream-get "/posts" host/blog-index) (dream-get "/new" host/blog-new-form) (dream-get "/tags" host/blog-tags-index) + (dream-get "/meta" host/blog-meta-index) (dream-get "/:slug/source" host/blog-source) (dream-get "/:slug/relate-options" host/blog-relate-options) (dream-get "/:slug" host/blog-post))) diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 6ddc31ed..c9040061 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -588,6 +588,20 @@ (list (host/blog-type-valid? "art1" "(p \"no heading\")") (host/blog-type-valid? "art1" "(article (h1 \"H\") (p \"x\"))"))) (list false true)) + +;; -- metamodel overview (GET /meta) -- +(host-bl-test "type-defs = the subtype hierarchy (type defs), not is-a instances" + (let ((defs (host/blog-type-defs))) + (list (contains? defs "type") (contains? defs "article") (contains? defs "art1"))) + (list true true false)) +(host-bl-test "/meta is 200 (not shadowed by /:slug)" + (dream-status (host-bl-app (host-bl-req "/meta"))) 200) +(host-bl-test "/meta lists type definitions + relations + the article's required block" + (let ((body (dream-resp-body (host-bl-app (host-bl-req "/meta"))))) + (list (contains? body "Metamodel") (contains? body "Article") + (contains? body "h1") (contains? body "related") + (contains? body "symmetric"))) + (list true true 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)"