Compare commits

..

48 Commits

Author SHA1 Message Date
4bbadee100 content: crdt-blocks regression suite — non-core blocks through flat + tree CRDT (738/738)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m1s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 07:42:41 +00:00
526838f320 content: fix ct-class-for-type for all block types (callout/media data round-trip) + 4 tests (731/731)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 42s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 07:04:50 +00:00
f71eaaa299 content: nested-tree CvRDT (crdt-tree.sx) + 17 convergence tests (727/727)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 06:22:25 +00:00
ec4cd63c22 content: multi-doc index + tag filtering (index.sx) + 13 tests (710/710)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 47s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 05:42:02 +00:00
c18545ea08 content: list-card summary projection (summary.sx) + 14 tests (697/697)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 52s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 05:25:24 +00:00
e115af86d8 content: video/audio media block (media.sx) + 15 tests (683/683)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 38s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 05:13:44 +00:00
715dbe248f content: relative block reorder (move.sx) + 11 tests (668/668)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 05:04:45 +00:00
c0ca2509d0 content: callout/admonition block (callout.sx) + 12 tests (657/657)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:57:40 +00:00
687f643d74 content: document flatten (flatten.sx) + 10 tests (645/645)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 18s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:50:16 +00:00
a343f4ea60 content: nested document outline (outline.sx) + 14 tests (635/635)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 22s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:41:42 +00:00
181cfb6e85 content: anchored-heading render (anchor.sx) + 6 tests (621/621)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 46s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:33:21 +00:00
b8ead3c223 content: global find/replace (find-replace.sx) + 10 tests (615/615)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 52s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:20:02 +00:00
49af154524 content: document normalization (normalize.sx) + 11 tests (605/605)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 19s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:11:48 +00:00
fe2475c49d content: TOC rendering (toc.sx) + 8 tests (594/594)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:04:03 +00:00
d9f2e7330e content: tree-wide block transforms (transform.sx) + 12 tests (586/586)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:56:05 +00:00
53bb3e97b4 content: block query + TOC (query.sx) + 13 tests (574/574)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m2s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:47:06 +00:00
c093fdcb54 content: id remapping / clone (clone.sx) + 10 tests (561/561)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 45s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:35:28 +00:00
4e26b3c0f7 content: deep tree editing (tree-edit.sx) + 17 tests (551/551)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m1s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:25:46 +00:00
90136f3a99 content: on-the-wire serialization (wire.sx) + 11 tests (534/534)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 40s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:18:09 +00:00
c5bc8d73a2 content: portable data serialization (data.sx) + 21 tests (523/523)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:11:10 +00:00
a5ff21015e content: document composition (compose.sx) + 17 tests (502/502)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 59s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:02:54 +00:00
20867a62c3 content: SEO page-full w/ meta description (page-full.sx) + 4 tests (485/485)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:55:23 +00:00
d994579598 content: Markdown doc export w/ frontmatter (md-doc.sx) + 12 tests (481/481)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 48s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:49:52 +00:00
26a51ac5d8 content: Markdown frontmatter -> metadata + 9 tests (469/469)
Some checks are pending
Test, Build, and Deploy / test-build-deploy (push) Waiting to run
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:44:02 +00:00
7610da1d6d content: Markdown table import + 5 tests (round-trip, 460/460)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m6s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:37:02 +00:00
950ca71a48 content: HTML page wrapper (page.sx) + 7 tests (455/455)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:24:23 +00:00
69defdc517 content: table block (table.sx) + 15 tests (448/448)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 36s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:17:44 +00:00
7791867bbc content: document statistics (stats.sx) + 17 tests (433/433)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 56s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:09:17 +00:00
e5a159f350 content: tree-aware validation (descends into sections) + 6 tests (416/416)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:03:25 +00:00
6e0edc347b content: nested block trees (section.sx) + 25 tests (410/410)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:56:22 +00:00
897172a5b8 content: plain-text render + excerpt (text.sx) + 20 tests (385/385)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 36s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:51:24 +00:00
a101f5a4c3 content: document metadata (meta.sx) + Ghost title plumbing + 27 tests (365/365)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 16s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:46:21 +00:00
b97504ab88 content: snapshot cache over op-log replay (snapshot.sx) + 20 tests (338/338)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:39:02 +00:00
295864786d content: Markdown import adapter (md-import) + 24 tests (318/318)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:33:50 +00:00
7836709f91 content: document validation (validate.sx) + 17 tests (294/294)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 46s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:25:37 +00:00
ef38b24110 content: durable CRDT replication (crdt-store) + 14 tests (277/277)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 36s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:19:15 +00:00
4fb4b04b21 content: Markdown render mode (asMarkdown) + 20 tests (263/263)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 45s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:13:44 +00:00
9c1c8f6b75 content: asSx wire string-escaping (String>>sxEscaped) + 5 tests (243/243)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 58s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:03:45 +00:00
2c1d8c8064 content: HTML escaping at render boundary (String>>htmlEscaped) + 8 tests (238/238)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 41s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:53:06 +00:00
9722e97e0a content: trust-gated federation + conflict tests (Phase 4 complete, roadmap done, 230/230)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 40s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:42:49 +00:00
ab48a3ba1f content: Ghost/CMS sync via injected adapter + round-trip tests (210/210)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 43s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:37:12 +00:00
edf0ab1755 content: CvRDT collaborative merge + 34 convergence tests (Phase 3 complete, 196/196)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 43s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:29:38 +00:00
18696f3251 content: persist-backed op log + versioning + diff (Phase 2 complete, 162/162)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:15:55 +00:00
8dc9187645 content: content/* API facade + 26 tests (Phase 1 complete, 133/133)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 52s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:08:42 +00:00
0d93a9820f content: render boundary (asHTML/asSx polymorphic) + 29 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 48s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:03:05 +00:00
6e52ad5126 content: ordered block document + edit ops + 40 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 36s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-06 23:57:34 +00:00
6a246039b5 content: typed block objects on smalltalk + 38 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 51s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-06 23:51:46 +00:00
d446562ed1 briefings: commerce / content / events / identity loop briefings
Authored from plans/{commerce,content,events,identity}-on-sx.md.
Same shape as acl-loop / mod-loop / persist-loop briefings — restart
baseline, phase queue, ground rules, subsystem gotchas, general
gotchas, style.

Substrate dependencies noted in each:
  commerce -> minikanren + persist + flow
  content  -> smalltalk + persist
  events   -> datalog + persist + flow
  identity -> erlang + persist + acl

Phase 1 of each is unblocked by the substrate that already exists;
later phases gate on persist (and friends) landing.
2026-06-06 23:25:15 +00:00
89 changed files with 8647 additions and 14 deletions

51
lib/content/anchor.sx Normal file
View File

@@ -0,0 +1,51 @@
;; content-on-sx — anchored-heading HTML render.
;;
;; Like asHTML, but headings carry an id attribute (the block id), so the TOC's
;; #id links resolve. A separate render so the plain asHTML stays unchanged.
;; Tree-aware (sections recurse); other blocks use their normal asHTML.
;;
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (asHTML +
;; htmlEscaped).
(define
anch-section?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define anch-esc (fn (s) (str (st-send s "htmlEscaped" (list)))))
(define
anchor-block
(fn
(b)
(cond
((= (blk-type b) "heading")
(let
((l (str (blk-get b "level"))) (id (blk-id b)))
(str
"<h"
l
" id=\""
id
"\">"
(anch-esc (str (blk-get b "text")))
"</h"
l
">")))
((anch-section? b)
(let
((ch (st-iv-get b "children")))
(str
"<section>"
(anchor-blocks (if (list? ch) ch (list)))
"</section>")))
(else (str (st-send b "asHTML" (list)))))))
(define
anchor-blocks
(fn
(blocks)
(if
(= (len blocks) 0)
""
(str (anchor-block (first blocks)) (anchor-blocks (rest blocks))))))
(define content/html-anchored (fn (doc) (anchor-blocks (doc-blocks doc))))

67
lib/content/api.sx Normal file
View File

@@ -0,0 +1,67 @@
;; content-on-sx — public API facade.
;;
;; The stable surface other code calls. Composes block + doc + render. Document
;; values are immutable; every edit returns a new document, so callers hold
;; explicit versions (the persist op log in Phase 2 becomes the source of truth).
;;
;; Requires (loaded by the harness): block.sx, doc.sx, render.sx and a base
;; Smalltalk class table (st-bootstrap-classes!).
;; Register the content class hierarchy + render methods. Caller bootstraps the
;; base Smalltalk classes first; this only adds content classes (idempotent).
(define
content/bootstrap!
(fn
()
(begin
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-render!)
true)))
;; ── documents ──
(define content/new doc-new)
(define content/empty doc-empty)
(define content/append doc-append)
(define content/blocks doc-blocks)
(define content/count doc-count)
(define content/find doc-find)
(define content/has? doc-has?)
(define content/ids doc-ids)
(define content/types doc-types)
;; ── blocks ──
(define content/block mk-block)
;; ── edit ops (data payload) ──
(define content/insert op-insert)
(define content/update op-update)
(define content/move op-move)
(define content/delete op-delete)
(define content/op? (fn (x) (and (dict? x) (has-key? x :op))))
;; edit — apply one op or a stream of ops; returns a new document.
(define
content/edit
(fn
(doc ops)
(if (content/op? ops) (doc-apply doc ops) (doc-apply-all doc ops))))
;; ── render boundary ──
;; fmt is "html"/"sx"/"md"/"text" (or the matching keyword). "md" needs
;; markdown.sx loaded; "text" needs text.sx loaded.
(define
content/render
(fn
(doc fmt)
(cond
((= fmt "html") (asHTML doc))
((= fmt "sx") (asSx doc))
((= fmt "md") (asMarkdown doc))
((= fmt "markdown") (asMarkdown doc))
((= fmt "text") (asText doc))
(else (error (str "unknown render format: " fmt))))))
(define content/html asHTML)
(define content/sx asSx)

171
lib/content/block.sx Normal file
View File

@@ -0,0 +1,171 @@
;; content-on-sx — typed block objects on Smalltalk-on-SX.
;;
;; A block is a Smalltalk instance. Behaviour (type tag, later render) is a
;; message, not a property switch. Fields are immutable: blk-set / mk-* build a
;; fresh instance via the functional st-iv-set!, so old versions are never
;; clobbered (history-safe for the persist op log and CRDT merge).
;;
;; Hierarchy:
;; CtBlock (id)
;; CtText (text)
;; CtHeading (level)
;; CtCode (language)
;; CtQuote (cite)
;; CtImage (src alt)
;; CtEmbed (url provider)
;; CtDivider
;; CtList (ordered items)
;; Plus self-contained blocks registered by their own files: CtSection,
;; CtTable, CtCallout, CtMedia. ct-class-for-type maps every tag (so mk-block,
;; content/from-data and CRDT materialise build them uniformly); the classes
;; themselves are registered by content-bootstrap-section!/table!/callout!/media!.
(define
ct-def-method!
(fn (cls sel src) (st-class-add-method! cls sel (st-parse-method src))))
;; Register the block hierarchy in the Smalltalk class table. Call AFTER
;; st-bootstrap-classes! (which resets the table). Idempotent.
(define
content-bootstrap-blocks!
(fn
()
(begin
(st-class-define! "CtBlock" "Object" (list "id"))
(ct-def-method! "CtBlock" "id" "id ^ id")
(ct-def-method! "CtBlock" "type" "type ^ #block")
(ct-def-method! "CtBlock" "isBlock" "isBlock ^ true")
(st-class-define! "CtText" "CtBlock" (list "text"))
(ct-def-method! "CtText" "text" "text ^ text")
(ct-def-method! "CtText" "type" "type ^ #text")
(st-class-define! "CtHeading" "CtText" (list "level"))
(ct-def-method! "CtHeading" "level" "level ^ level")
(ct-def-method! "CtHeading" "type" "type ^ #heading")
(st-class-define! "CtCode" "CtText" (list "language"))
(ct-def-method! "CtCode" "language" "language ^ language")
(ct-def-method! "CtCode" "type" "type ^ #code")
(st-class-define! "CtQuote" "CtText" (list "cite"))
(ct-def-method! "CtQuote" "cite" "cite ^ cite")
(ct-def-method! "CtQuote" "type" "type ^ #quote")
(st-class-define! "CtImage" "CtBlock" (list "src" "alt"))
(ct-def-method! "CtImage" "src" "src ^ src")
(ct-def-method! "CtImage" "alt" "alt ^ alt")
(ct-def-method! "CtImage" "type" "type ^ #image")
(st-class-define! "CtEmbed" "CtBlock" (list "url" "provider"))
(ct-def-method! "CtEmbed" "url" "url ^ url")
(ct-def-method! "CtEmbed" "provider" "provider ^ provider")
(ct-def-method! "CtEmbed" "type" "type ^ #embed")
(st-class-define! "CtDivider" "CtBlock" (list))
(ct-def-method! "CtDivider" "type" "type ^ #divider")
(st-class-define! "CtList" "CtBlock" (list "ordered" "items"))
(ct-def-method! "CtList" "ordered" "ordered ^ ordered")
(ct-def-method! "CtList" "items" "items ^ items")
(ct-def-method! "CtList" "type" "type ^ #list")
true)))
;; Apply (name value) pairs functionally onto a fresh instance.
(define
ct-apply-fields
(fn
(inst pairs)
(if
(= (len pairs) 0)
inst
(ct-apply-fields
(st-iv-set!
inst
(first (first pairs))
(first (rest (first pairs))))
(rest pairs)))))
(define
ct-class-for-type
(fn
(tag)
(cond
((= tag "text") "CtText")
((= tag "heading") "CtHeading")
((= tag "code") "CtCode")
((= tag "quote") "CtQuote")
((= tag "image") "CtImage")
((= tag "embed") "CtEmbed")
((= tag "divider") "CtDivider")
((= tag "list") "CtList")
((= tag "section") "CtSection")
((= tag "table") "CtTable")
((= tag "callout") "CtCallout")
((= tag "media") "CtMedia")
(else (error (str "unknown block type: " tag))))))
;; Generic constructor — wire tag + id + (name value) field pairs.
(define
mk-block
(fn
(type-tag id fields)
(ct-apply-fields
(st-iv-set! (st-make-instance (ct-class-for-type type-tag)) "id" id)
fields)))
(define
mk-text
(fn (id text) (mk-block "text" id (list (list "text" text)))))
(define
mk-heading
(fn
(id level text)
(mk-block "heading" id (list (list "level" level) (list "text" text)))))
(define
mk-code
(fn
(id language text)
(mk-block
"code"
id
(list (list "language" language) (list "text" text)))))
(define
mk-quote
(fn
(id cite text)
(mk-block "quote" id (list (list "cite" cite) (list "text" text)))))
(define
mk-image
(fn
(id src alt)
(mk-block "image" id (list (list "src" src) (list "alt" alt)))))
(define
mk-embed
(fn
(id url provider)
(mk-block "embed" id (list (list "url" url) (list "provider" provider)))))
(define mk-divider (fn (id) (mk-block "divider" id (list))))
(define
mk-list
(fn
(id ordered items)
(mk-block
"list"
id
(list (list "ordered" ordered) (list "items" items)))))
;; Accessors. blk-type / blk-id go through message dispatch (polymorphic);
;; blk-get reads any ivar directly; blk-set is copy-on-write.
(define blk-id (fn (b) (st-send b "id" (list))))
(define blk-type (fn (b) (str (st-send b "type" (list)))))
(define blk-send (fn (b sel) (st-send b sel (list))))
(define blk-get (fn (b field) (st-iv-get b field)))
(define blk-set (fn (b field val) (st-iv-set! b field val)))
(define
block?
(fn
(v)
(and
(st-instance? v)
(st-class-inherits-from? (get v :class) "CtBlock"))))

49
lib/content/callout.sx Normal file
View File

@@ -0,0 +1,49 @@
;; content-on-sx — callout / admonition block.
;;
;; CtCallout holds a `kind` (note/warning/tip/…) and `text`. Self-contained: it
;; answers asHTML/asSx/asText/asMarkdown: so it composes with the render boundary
;; with no changes elsewhere. HTML text is htmlEscaped, SX text sxEscaped.
;;
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (escapers);
;; markdown.sx / text.sx for those formats.
(define
content-bootstrap-callout!
(fn
()
(begin
(st-class-define! "CtCallout" "CtBlock" (list "kind" "text"))
(ct-def-method! "CtCallout" "kind" "kind ^ kind")
(ct-def-method! "CtCallout" "text" "text ^ text")
(ct-def-method! "CtCallout" "type" "type ^ #callout")
(ct-def-method!
"CtCallout"
"asHTML"
"asHTML ^ '<aside class=\"callout callout-' , kind htmlEscaped , '\">' , text htmlEscaped , '</aside>'")
(ct-def-method!
"CtCallout"
"asSx"
"asSx ^ '(aside :class \"callout callout-' , kind sxEscaped , '\" \"' , text sxEscaped , '\")'")
(ct-def-method! "CtCallout" "asText" "asText ^ text")
(ct-def-method!
"CtCallout"
"asMarkdown:"
"asMarkdown: nl ^ '> **' , kind , ':** ' , text")
true)))
(define
mk-callout
(fn
(id kind text)
(st-iv-set!
(st-iv-set!
(st-iv-set! (st-make-instance "CtCallout") "id" id)
"kind"
kind)
"text"
text)))
(define
callout?
(fn (b) (and (st-instance? b) (= (get b :class) "CtCallout"))))
(define callout-kind (fn (b) (st-send b "kind" (list))))

34
lib/content/clone.sx Normal file
View File

@@ -0,0 +1,34 @@
;; content-on-sx — block id remapping / clone.
;;
;; Deep-rewrite every block id in the tree (descending into sections) by applying
;; a function. Enables collision-free composition: prefix one document's ids
;; before concatenating it with another. Immutable; content is unchanged, only
;; ids.
;;
;; Requires (loaded by harness): doc.sx, section.sx (section? /
;; section-children / section-with-children).
(define
block-remap-id
(fn
(b f)
(let
((nb (blk-set b "id" (f (blk-id b)))))
(if
(section? nb)
(section-with-children
nb
(map (fn (c) (block-remap-id c f)) (section-children nb)))
nb))))
(define
content/remap-ids
(fn
(doc f)
(doc-with-blocks
doc
(map (fn (b) (block-remap-id b f)) (doc-blocks doc)))))
(define
content/prefix-ids
(fn (doc prefix) (content/remap-ids doc (fn (id) (str prefix id)))))

42
lib/content/compose.sx Normal file
View File

@@ -0,0 +1,42 @@
;; content-on-sx — document composition.
;;
;; Combine documents (header + body + footer, templates, partials) into a new
;; document. The result keeps the FIRST document's id and metadata; blocks are
;; concatenated. Immutable — inputs are untouched. Block-id collisions across
;; combined docs are the caller's concern (content/validate flags duplicates).
;;
;; Requires (loaded by harness): doc.sx.
(define
content/concat
(fn (a b) (doc-with-blocks a (append (doc-blocks a) (doc-blocks b)))))
(define
content/prepend
(fn (a b) (doc-with-blocks a (append (doc-blocks b) (doc-blocks a)))))
(define
content/-concat-fold
(fn
(acc more)
(if
(= (len more) 0)
acc
(content/-concat-fold (content/concat acc (first more)) (rest more)))))
(define
content/concat-all
(fn
(docs)
(if
(= (len docs) 0)
(doc-empty "merged")
(content/-concat-fold (first docs) (rest docs)))))
;; wrap a document's blocks inside a single section (collapse to a subtree).
;; Requires section.sx (mk-section) when used.
(define
content/wrap-section
(fn
(doc section-id)
(doc-with-blocks doc (list (mk-section section-id (doc-blocks doc))))))

158
lib/content/conformance.sh Executable file
View File

@@ -0,0 +1,158 @@
#!/usr/bin/env bash
# lib/content/conformance.sh — run content-on-sx suites, emit scoreboard.
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
if [ ! -x "$SX_SERVER" ]; then
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
else
echo "ERROR: sx_server.exe not found." >&2
exit 1
fi
fi
SUITES=(block doc render api meta page page-full markdown text section compose tree-edit move clone query toc anchor outline flatten transform normalize find-replace stats summary index table callout media data wire validate store snapshot crdt crdt-tree crdt-blocks crdt-store sync md-import md-doc fed)
OUT_JSON="lib/content/scoreboard.json"
OUT_MD="lib/content/scoreboard.md"
run_suite() {
local suite=$1
local file="lib/content/tests/${suite}.sx"
local TMP
TMP=$(mktemp)
cat > "$TMP" << EPOCHS
(epoch 1)
(load "lib/smalltalk/tokenizer.sx")
(load "lib/smalltalk/parser.sx")
(load "lib/guest/reflective/class-chain.sx")
(load "lib/smalltalk/runtime.sx")
(load "lib/guest/reflective/env.sx")
(load "lib/smalltalk/eval.sx")
(load "lib/persist/event.sx")
(load "lib/persist/backend.sx")
(load "lib/persist/log.sx")
(load "lib/persist/kv.sx")
(load "lib/persist/api.sx")
(load "lib/content/block.sx")
(load "lib/content/doc.sx")
(load "lib/content/render.sx")
(load "lib/content/api.sx")
(load "lib/content/meta.sx")
(load "lib/content/text.sx")
(load "lib/content/section.sx")
(load "lib/content/compose.sx")
(load "lib/content/tree-edit.sx")
(load "lib/content/move.sx")
(load "lib/content/clone.sx")
(load "lib/content/query.sx")
(load "lib/content/toc.sx")
(load "lib/content/anchor.sx")
(load "lib/content/outline.sx")
(load "lib/content/flatten.sx")
(load "lib/content/transform.sx")
(load "lib/content/normalize.sx")
(load "lib/content/find-replace.sx")
(load "lib/content/stats.sx")
(load "lib/content/summary.sx")
(load "lib/content/index.sx")
(load "lib/content/table.sx")
(load "lib/content/callout.sx")
(load "lib/content/media.sx")
(load "lib/content/data.sx")
(load "lib/content/wire.sx")
(load "lib/content/page.sx")
(load "lib/content/page-full.sx")
(load "lib/content/markdown.sx")
(load "lib/content/validate.sx")
(load "lib/content/store.sx")
(load "lib/content/snapshot.sx")
(load "lib/content/crdt.sx")
(load "lib/content/crdt-tree.sx")
(load "lib/content/crdt-store.sx")
(load "lib/content/sync.sx")
(load "lib/content/md-import.sx")
(load "lib/content/md-doc.sx")
(load "lib/content/fed.sx")
(epoch 2)
(eval "(define content-test-pass 0)")
(eval "(define content-test-fail 0)")
(eval "(define content-test-fails (list))")
(eval "(define content-test (fn (name got expected) (if (= got expected) (set! content-test-pass (+ content-test-pass 1)) (begin (set! content-test-fail (+ content-test-fail 1)) (set! content-test-fails (cons name content-test-fails))))))")
(epoch 3)
(load "${file}")
(epoch 4)
(eval "(list content-test-pass content-test-fail)")
EPOCHS
local OUTPUT
OUTPUT=$(timeout 240 "$SX_SERVER" < "$TMP" 2>/dev/null)
rm -f "$TMP"
local LINE
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 4 //; s/\)$//')
fi
local P F
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
P=${P:-0}
F=${F:-0}
echo "${P} ${F}"
}
declare -A SUITE_PASS
declare -A SUITE_FAIL
TOTAL_PASS=0
TOTAL_FAIL=0
echo "Running content conformance suite..." >&2
for s in "${SUITES[@]}"; do
read -r p f < <(run_suite "$s")
SUITE_PASS[$s]=$p
SUITE_FAIL[$s]=$f
TOTAL_PASS=$((TOTAL_PASS + p))
TOTAL_FAIL=$((TOTAL_FAIL + f))
printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
done
{
printf '{\n'
printf ' "suites": {\n'
first=1
for s in "${SUITES[@]}"; do
if [ $first -eq 0 ]; then printf ',\n'; fi
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
first=0
done
printf '\n },\n'
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
printf '}\n'
} > "$OUT_JSON"
{
printf '# content-on-sx Conformance Scoreboard\n\n'
printf '_Generated by `lib/content/conformance.sh`_\n\n'
printf '| Suite | Pass | Fail | Total |\n'
printf '|-------|-----:|-----:|------:|\n'
for s in "${SUITES[@]}"; do
p=${SUITE_PASS[$s]}
f=${SUITE_FAIL[$s]}
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
done
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
} > "$OUT_MD"
echo "Wrote $OUT_JSON and $OUT_MD" >&2
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
[ "$TOTAL_FAIL" -eq 0 ]

71
lib/content/crdt-store.sx Normal file
View File

@@ -0,0 +1,71 @@
;; content-on-sx — durable collaborative replication: CRDT ops on persist.
;;
;; Each replica appends its CRDT ops to its own persist stream
;; (crdt:<doc>:<replica>). Any node reconstructs the converged document by
;; replaying every replica's log into a CvRDT state and merging them. Because
;; the merge is a join and crdt-apply is order/duplicate-insensitive, the
;; converged result is identical regardless of replica order or re-delivery —
;; the durable log + CRDT give offline-capable, eventually-consistent editing.
;;
;; Requires (loaded by harness): crdt.sx (+ deps) and persist
;; (event/backend/log/kv/api). Backend `b` injected via (persist/open).
(define crdt/-stream (fn (doc-id replica) (str "crdt:" doc-id ":" replica)))
;; ── commit ops to a replica's durable log ──
(define
crdt/commit!
(fn
(b doc-id replica op at)
(persist/append b (crdt/-stream doc-id replica) (get op :op) at op)))
(define
crdt/commit-all!
(fn
(b doc-id replica ops at)
(if
(= (len ops) 0)
nil
(begin
(crdt/commit! b doc-id replica (first ops) at)
(crdt/commit-all! b doc-id replica (rest ops) at)))))
;; ── read a replica's log ──
(define
crdt/log
(fn (b doc-id replica) (persist/read b (crdt/-stream doc-id replica))))
(define
crdt/replica-ops
(fn
(b doc-id replica)
(map (fn (ev) (persist/event-data ev)) (crdt/log b doc-id replica))))
(define
crdt/replica-version
(fn (b doc-id replica) (persist/last-seq b (crdt/-stream doc-id replica))))
;; ── replay one replica's log into a CvRDT state ──
(define
crdt/replay
(fn
(b doc-id replica)
(crdt-apply-all (crdt-empty) (crdt/replica-ops b doc-id replica))))
;; ── converge: merge every replica's replayed state ──
(define
crdt/converge
(fn
(b doc-id replicas)
(crdt-merge-all (map (fn (r) (crdt/replay b doc-id r)) replicas))))
;; ── converged, materialised document ──
(define
crdt/document
(fn
(b doc-id replicas)
(crdt-materialize doc-id (crdt/converge b doc-id replicas))))
(define
crdt/order
(fn (b doc-id replicas) (crdt-order (crdt/converge b doc-id replicas))))

164
lib/content/crdt-tree.sx Normal file
View File

@@ -0,0 +1,164 @@
;; content-on-sx — nested-tree CvRDT.
;;
;; Extends the flat CvRDT (crdt.sx) to a TREE: each element carries a `parent`
;; (the id of its containing section, "" = root) alongside its Logoot position.
;; Merge is still a join — it reuses crdt.sx's position/register/field merges and
;; adds parent (immutable, set once at insert). Materialisation rebuilds the
;; ordered tree: root = elements with parent "", a section's children = elements
;; whose parent is that section's id, each sorted by position. Commutative,
;; associative, idempotent like the flat layer; concurrent inserts into the same
;; or different parents converge deterministically.
;;
;; Requires (loaded by harness): crdt.sx (merge helpers + live/sort/materialise
;; bits), block.sx, doc.sx, section.sx (mk-section).
(define ctt-merge-parent (fn (p1 p2) (if (= p1 nil) p2 p1)))
(define ctt-merge-element (fn (e1 e2) {:fields (crdt-merge-fields (get e1 :fields) (get e2 :fields)) :parent (ctt-merge-parent (get e1 :parent) (get e2 :parent)) :id (get e1 :id) :type (crdt-merge-type (get e1 :type) (get e2 :type)) :deleted (or (= (get e1 :deleted) true) (= (get e2 :deleted) true)) :pos (crdt-merge-pos (get e1 :pos) (get e2 :pos))}))
(define
ctt-add-element
(fn
(state elem)
(let
((elems (get state :elements)) (id (get elem :id)))
(let
((existing (get elems id)))
(assoc
state
:elements (assoc
elems
id
(if (= existing nil) elem (ctt-merge-element existing elem))))))))
;; ── ops as partial-element contributions ──
(define
crdt-tree-insert
(fn
(state id type pos parent fields ts actor)
(ctt-add-element state {:fields (crdt-build-fields fields ts actor) :parent parent :id id :type type :deleted false :pos pos})))
(define
crdt-tree-update
(fn (state id fname value ts actor) (ctt-add-element state {:fields (assoc {} fname {:ts ts :actor actor :value value}) :parent nil :id id :type nil :deleted false :pos nil})))
(define crdt-tree-delete (fn (state id) (ctt-add-element state {:fields {} :parent nil :id id :type nil :deleted true :pos nil})))
;; ── state merge (join) ──
(define
ctt-merge-loop
(fn
(ids ea eb acc)
(if
(= (len ids) 0)
acc
(let
((id (first ids)))
(let
((x (get ea id)) (y (get eb id)))
(ctt-merge-loop
(rest ids)
ea
eb
(assoc
acc
id
(cond
((= x nil) y)
((= y nil) x)
(else (ctt-merge-element x y))))))))))
(define crdt-tree-merge (fn (a b) {:elements (ctt-merge-loop (crdt-union-keys (get a :elements) (get b :elements)) (get a :elements) (get b :elements) {})}))
(define
crdt-tree-merge-all
(fn
(states)
(if
(= (len states) 0)
(crdt-empty)
(if
(= (len states) 1)
(first states)
(crdt-tree-merge (first states) (crdt-tree-merge-all (rest states)))))))
;; ── op interpreter ──
(define
crdt-tree-op-insert
(fn (id type pos parent fields ts actor) {:ts ts :fields fields :parent parent :id id :type type :op "insert" :actor actor :pos pos}))
(define crdt-tree-op-update (fn (id field value ts actor) {:ts ts :field field :id id :op "update" :actor actor :value value}))
(define crdt-tree-op-delete (fn (id) {:id id :op "delete"}))
(define
crdt-tree-apply
(fn
(state op)
(let
((k (get op :op)))
(cond
((= k "insert")
(crdt-tree-insert
state
(get op :id)
(get op :type)
(get op :pos)
(get op :parent)
(get op :fields)
(get op :ts)
(get op :actor)))
((= k "update")
(crdt-tree-update
state
(get op :id)
(get op :field)
(get op :value)
(get op :ts)
(get op :actor)))
((= k "delete") (crdt-tree-delete state (get op :id)))
(else (error (str "unknown crdt-tree op: " k)))))))
(define
crdt-tree-apply-all
(fn
(state ops)
(if
(= (len ops) 0)
state
(crdt-tree-apply-all (crdt-tree-apply state (first ops)) (rest ops)))))
;; ── materialise to a Phase-1 document (rebuild the ordered tree) ──
(define
ctt-children
(fn
(state parent-id)
(crdt-sort-by-pos
(filter
(fn (e) (= (get e :parent) parent-id))
(crdt-live-elements state)))))
(define
ctt-element->block
(fn
(state e)
(if
(= (get e :type) "section")
(mk-section
(get e :id)
(map
(fn (c) (ctt-element->block state c))
(ctt-children state (get e :id))))
(crdt-element->block e))))
(define
crdt-tree-materialize
(fn
(doc-id state)
(doc-new
doc-id
(map (fn (e) (ctt-element->block state e)) (ctt-children state "")))))
(define
crdt-tree-order
(fn (state) (map (fn (e) (get e :id)) (ctt-children state ""))))

378
lib/content/crdt.sx Normal file
View File

@@ -0,0 +1,378 @@
;; content-on-sx — collaborative merge (state-based CvRDT).
;;
;; The merge is a join (least upper bound) on a semilattice, so it is
;; commutative, associative and idempotent BY CONSTRUCTION — applying ops in any
;; order, or merging replicas in any order / twice, converges to the same
;; document. This is NOT last-write-wins-as-cop-out: ordering uses unique dense
;; position keys (Logoot), presence uses OR-tombstones (remove-wins), and each
;; field is an LWW-Register keyed by a logical (ts, actor) clock — an explicit,
;; deterministic per-field conflict policy.
;;
;; Every op (insert/update/delete) contributes a PARTIAL element; the per-id
;; state is the join of all contributions. So update-before-insert and
;; delete-before-insert are not lost — they merge when the rest arrives.
;;
;; Shapes:
;; state = {:elements <dict id -> element>}
;; element = {:id :pos :type :deleted :fields <dict fname -> register>}
;; register = {:value v :ts <int> :actor <int>}
;; position = list of cells; cell = (list digit actor); lexicographic order
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define CRDT-BASE 65536)
;; ── position order (Logoot) ──
(define
crdt-cell-cmp
(fn
(c1 c2)
(let
((d1 (first c1)) (d2 (first c2)))
(cond
((< d1 d2) -1)
((> d1 d2) 1)
(else
(let
((a1 (first (rest c1))) (a2 (first (rest c2))))
(cond
((< a1 a2) -1)
((> a1 a2) 1)
(else 0))))))))
(define
crdt-pos-compare
(fn
(p1 p2)
(cond
((and (= (len p1) 0) (= (len p2) 0)) 0)
((= (len p1) 0) -1)
((= (len p2) 0) 1)
(else
(let
((c (crdt-cell-cmp (first p1) (first p2))))
(if (= c 0) (crdt-pos-compare (rest p1) (rest p2)) c))))))
;; single-cell position constructor (handy for explicit tests)
(define crdt-pos (fn (digit actor) (list (list digit actor))))
;; allocate a position strictly between left and right (nil = unbounded)
(define
cr-alloc
(fn
(left right actor i acc)
(let
((ld (if (< i (len left)) (first (nth left i)) 0))
(rd (if (< i (len right)) (first (nth right i)) CRDT-BASE)))
(if
(> (- rd ld) 1)
(append
acc
(list
(list
(+
ld
(+
1
(floor (/ (- (- rd ld) 1) 2))))
actor)))
(cr-alloc
left
right
actor
(+ i 1)
(append
acc
(list
(list
ld
(if (< i (len left)) (first (rest (nth left i))) actor)))))))))
(define
crdt-pos-between
(fn
(left right actor)
(cr-alloc
(if (= left nil) (list) left)
(if (= right nil) (list) right)
actor
0
(list))))
;; ── register (LWW by logical (ts, actor)) ──
(define
crdt-reg-max
(fn
(r1 r2)
(cond
((= r1 nil) r2)
((= r2 nil) r1)
(else
(let
((t1 (get r1 :ts)) (t2 (get r2 :ts)))
(cond
((> t1 t2) r1)
((< t1 t2) r2)
(else (if (>= (get r1 :actor) (get r2 :actor)) r1 r2))))))))
;; ── small set/dict helpers ──
(define
crdt-member?
(fn
(x xs)
(cond
((= (len xs) 0) false)
((= (first xs) x) true)
(else (crdt-member? x (rest xs))))))
(define
crdt-dedup-loop
(fn
(xs seen)
(if
(= (len xs) 0)
(reverse seen)
(if
(crdt-member? (first xs) seen)
(crdt-dedup-loop (rest xs) seen)
(crdt-dedup-loop (rest xs) (cons (first xs) seen))))))
(define crdt-dedup (fn (xs) (crdt-dedup-loop xs (list))))
(define
crdt-union-keys
(fn (d1 d2) (crdt-dedup (append (keys d1) (keys d2)))))
;; ── element join ──
(define
crdt-merge-pos
(fn
(p1 p2)
(cond
((= p1 nil) p2)
((= p2 nil) p1)
((<= (crdt-pos-compare p1 p2) 0) p1)
(else p2))))
(define crdt-merge-type (fn (t1 t2) (if (= t1 nil) t2 t1)))
(define
crdt-merge-fields-loop
(fn
(names f1 f2 acc)
(if
(= (len names) 0)
acc
(let
((nm (first names)))
(crdt-merge-fields-loop
(rest names)
f1
f2
(assoc acc nm (crdt-reg-max (get f1 nm) (get f2 nm))))))))
(define
crdt-merge-fields
(fn
(f1 f2)
(crdt-merge-fields-loop (crdt-union-keys f1 f2) f1 f2 {})))
(define crdt-merge-element (fn (e1 e2) {:fields (crdt-merge-fields (get e1 :fields) (get e2 :fields)) :id (get e1 :id) :type (crdt-merge-type (get e1 :type) (get e2 :type)) :deleted (or (= (get e1 :deleted) true) (= (get e2 :deleted) true)) :pos (crdt-merge-pos (get e1 :pos) (get e2 :pos))}))
;; ── state ──
(define crdt-empty (fn () {:elements {}}))
(define
crdt-add-element
(fn
(state elem)
(let
((elems (get state :elements)) (id (get elem :id)))
(let
((existing (get elems id)))
(assoc
state
:elements (assoc
elems
id
(if (= existing nil) elem (crdt-merge-element existing elem))))))))
(define
crdt-build-fields-loop
(fn
(pairs ts actor acc)
(if
(= (len pairs) 0)
acc
(crdt-build-fields-loop
(rest pairs)
ts
actor
(assoc acc (first (first pairs)) {:ts ts :actor actor :value (first (rest (first pairs)))})))))
(define
crdt-build-fields
(fn (pairs ts actor) (crdt-build-fields-loop pairs ts actor {})))
;; ── ops as partial-element contributions ──
(define
crdt-insert
(fn
(state id type pos fields ts actor)
(crdt-add-element state {:fields (crdt-build-fields fields ts actor) :id id :type type :deleted false :pos pos})))
(define
crdt-update
(fn (state id fname value ts actor) (crdt-add-element state {:fields (assoc {} fname {:ts ts :actor actor :value value}) :id id :type nil :deleted false :pos nil})))
(define crdt-delete (fn (state id) (crdt-add-element state {:fields {} :id id :type nil :deleted true :pos nil})))
;; ── state merge (join) ──
(define
crdt-merge-loop
(fn
(ids ea eb acc)
(if
(= (len ids) 0)
acc
(let
((id (first ids)))
(let
((x (get ea id)) (y (get eb id)))
(crdt-merge-loop
(rest ids)
ea
eb
(assoc
acc
id
(cond
((= x nil) y)
((= y nil) x)
(else (crdt-merge-element x y))))))))))
(define crdt-merge (fn (a b) {:elements (crdt-merge-loop (crdt-union-keys (get a :elements) (get b :elements)) (get a :elements) (get b :elements) {})}))
(define
crdt-merge-all
(fn
(states)
(if
(= (len states) 0)
(crdt-empty)
(if
(= (len states) 1)
(first states)
(crdt-merge (first states) (crdt-merge-all (rest states)))))))
;; ── op interpreter ──
(define crdt-op-insert (fn (id type pos fields ts actor) {:ts ts :fields fields :id id :type type :op "insert" :actor actor :pos pos}))
(define crdt-op-update (fn (id field value ts actor) {:ts ts :field field :id id :op "update" :actor actor :value value}))
(define crdt-op-delete (fn (id) {:id id :op "delete"}))
(define
crdt-apply
(fn
(state op)
(let
((k (get op :op)))
(cond
((= k "insert")
(crdt-insert
state
(get op :id)
(get op :type)
(get op :pos)
(get op :fields)
(get op :ts)
(get op :actor)))
((= k "update")
(crdt-update
state
(get op :id)
(get op :field)
(get op :value)
(get op :ts)
(get op :actor)))
((= k "delete") (crdt-delete state (get op :id)))
(else (error (str "unknown crdt op: " k)))))))
(define
crdt-apply-all
(fn
(state ops)
(if
(= (len ops) 0)
state
(crdt-apply-all (crdt-apply state (first ops)) (rest ops)))))
;; ── materialise to a Phase-1 document ──
(define
crdt-elements-list
(fn
(state)
(map
(fn (id) (get (get state :elements) id))
(keys (get state :elements)))))
(define
crdt-live?
(fn
(e)
(and
(= (get e :deleted) false)
(if (= (get e :pos) nil) false true)
(if (= (get e :type) nil) false true))))
(define
crdt-live-elements
(fn (state) (filter crdt-live? (crdt-elements-list state))))
(define
crdt-insert-sorted
(fn
(e sorted)
(cond
((= (len sorted) 0) (list e))
((< (crdt-pos-compare (get e :pos) (get (first sorted) :pos)) 0)
(cons e sorted))
(else (cons (first sorted) (crdt-insert-sorted e (rest sorted)))))))
(define
crdt-sort-by-pos
(fn
(elems)
(if
(= (len elems) 0)
(list)
(crdt-insert-sorted (first elems) (crdt-sort-by-pos (rest elems))))))
(define
crdt-field-pairs
(fn
(fields)
(map (fn (nm) (list nm (get (get fields nm) :value))) (keys fields))))
(define
crdt-element->block
(fn
(e)
(mk-block (get e :type) (get e :id) (crdt-field-pairs (get e :fields)))))
(define
crdt-order
(fn
(state)
(map
(fn (e) (get e :id))
(crdt-sort-by-pos (crdt-live-elements state)))))
(define
crdt-materialize
(fn
(doc-id state)
(doc-new
doc-id
(map crdt-element->block (crdt-sort-by-pos (crdt-live-elements state))))))

79
lib/content/data.sx Normal file
View File

@@ -0,0 +1,79 @@
;; content-on-sx — portable data serialization.
;;
;; Converts documents to/from a plain SX data form, decoupling storage and
;; transport from the Smalltalk instance shape. A document becomes
;; {:id :title :slug :tags :blocks (list block-data)}
;; and a block becomes {:id :type :fields {...}} (section children recurse).
;; content/from-data reconstructs real block objects.
;;
;; Requires (loaded by harness): block.sx, doc.sx, meta.sx, section.sx
;; (mk-section), table.sx (mk-table).
;; ── to-data ──
(define
content/-fd-loop
(fn
(ks ivs acc)
(if
(= (len ks) 0)
acc
(let
((k (first ks)))
(if
(= k "id")
(content/-fd-loop (rest ks) ivs acc)
(content/-fd-loop
(rest ks)
ivs
(assoc
acc
k
(if
(= k "children")
(map block->data (get ivs k))
(get ivs k)))))))))
(define block->data (fn (b) {:fields (content/-fd-loop (keys (get b :ivars)) (get b :ivars) {}) :id (blk-id b) :type (blk-type b)}))
(define content/to-data (fn (doc) {:blocks (map block->data (doc-blocks doc)) :slug (doc-slug doc) :id (doc-id doc) :title (doc-title doc) :tags (doc-tags doc)}))
;; ── from-data ──
(define
content/-field-pairs
(fn (fields) (map (fn (k) (list k (get fields k))) (keys fields))))
(define
data->block
(fn
(d)
(let
((type (get d :type)) (id (get d :id)) (fields (get d :fields)))
(cond
((= type "section")
(mk-section id (map data->block (get fields "children"))))
((= type "table")
(mk-table id (get fields "headers") (get fields "rows")))
(else (mk-block type id (content/-field-pairs fields)))))))
(define
content/-meta-of
(fn
(data)
(let
((m1 (if (= (get data :title) nil) {} (assoc {} :title (get data :title)))))
(let
((m2 (if (= (get data :slug) nil) m1 (assoc m1 :slug (get data :slug)))))
(let
((tags (get data :tags)))
(if
(or (= tags nil) (= (len tags) 0))
m2
(assoc m2 :tags tags)))))))
(define
content/from-data
(fn
(data)
(doc-with-meta
(doc-new (get data :id) (map data->block (get data :blocks)))
(content/-meta-of data))))

203
lib/content/doc.sx Normal file
View File

@@ -0,0 +1,203 @@
;; content-on-sx — ordered block document on Smalltalk-on-SX.
;;
;; A document (CtDoc) is a Smalltalk object holding an ordered sequence of block
;; objects. Editing is a stream of ops (data dicts); doc-apply interprets one op
;; and returns a NEW document — the input is never mutated, so any version is the
;; head of an op stream (replay-friendly for persist + CRDT merge).
;;
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx for the
;; ergonomic API; they default nil and do not affect block operations.
;;
;; Op shapes (data, not objects — they are the persist event payload):
;; {:op "insert" :block <blk> :after <id|nil>} ; after nil = prepend
;; {:op "update" :id <id> :field <name> :value <v>}
;; {:op "move" :id <id> :index <n>}
;; {:op "delete" :id <id>}
(define
content-bootstrap-doc!
(fn
()
(begin
(st-class-define!
"CtDoc"
"Object"
(list "id" "blocks" "title" "slug" "tags"))
(ct-def-method! "CtDoc" "id" "id ^ id")
(ct-def-method! "CtDoc" "blocks" "blocks ^ blocks")
(ct-def-method! "CtDoc" "type" "type ^ #document")
(ct-def-method! "CtDoc" "title" "title ^ title")
(ct-def-method! "CtDoc" "slug" "slug ^ slug")
(ct-def-method! "CtDoc" "tags" "tags ^ tags")
true)))
;; ── construction ──
(define
doc-new
(fn
(id blocks)
(st-iv-set!
(st-iv-set! (st-make-instance "CtDoc") "id" id)
"blocks"
blocks)))
(define doc-empty (fn (id) (doc-new id (list))))
;; ── accessors (message dispatch) ──
(define doc-id (fn (doc) (st-send doc "id" (list))))
(define doc-type (fn (doc) (str (st-send doc "type" (list)))))
(define doc-blocks (fn (doc) (st-send doc "blocks" (list))))
(define doc-count (fn (doc) (len (doc-blocks doc))))
(define doc-block-at (fn (doc i) (nth (doc-blocks doc) i)))
(define doc? (fn (v) (and (st-instance? v) (= (get v :class) "CtDoc"))))
;; ── list helpers over block sequences ──
(define
ct-index-loop
(fn
(blocks id i)
(cond
((= (len blocks) 0) -1)
((= (blk-id (first blocks)) id) i)
(else (ct-index-loop (rest blocks) id (+ i 1))))))
(define ct-index-of (fn (blocks id) (ct-index-loop blocks id 0)))
(define
ct-insert-at
(fn
(blocks i x)
(cond
((= i 0) (cons x blocks))
((= (len blocks) 0) (list x))
(else
(cons
(first blocks)
(ct-insert-at (rest blocks) (- i 1) x))))))
(define
ct-remove-id
(fn
(blocks id)
(filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))
(define
ct-replace-id
(fn
(blocks id f)
(map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))
;; ── query ──
(define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
(define
doc-find
(fn
(doc id)
(let
((hits (filter (fn (b) (= (blk-id b) id)) (doc-blocks doc))))
(if (= (len hits) 0) nil (first hits)))))
(define
doc-has?
(fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
;; ── structural edits (each returns a new document) ──
(define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
(define
doc-append
(fn
(doc block)
(doc-with-blocks doc (append (doc-blocks doc) (list block)))))
(define
doc-insert-at
(fn
(doc block i)
(doc-with-blocks doc (ct-insert-at (doc-blocks doc) i block))))
(define
doc-insert-after
(fn
(doc block after-id)
(let
((blocks (doc-blocks doc)))
(if
(= after-id nil)
(doc-with-blocks doc (cons block blocks))
(let
((idx (ct-index-of blocks after-id)))
(if
(= idx -1)
(doc-with-blocks doc (append blocks (list block)))
(doc-with-blocks
doc
(ct-insert-at blocks (+ idx 1) block))))))))
(define
doc-update
(fn
(doc id field value)
(doc-with-blocks
doc
(ct-replace-id (doc-blocks doc) id (fn (b) (blk-set b field value))))))
(define
doc-delete
(fn (doc id) (doc-with-blocks doc (ct-remove-id (doc-blocks doc) id))))
(define
doc-move
(fn
(doc id i)
(let
((blk (doc-find doc id)))
(if
(= blk nil)
doc
(doc-with-blocks
doc
(ct-insert-at (ct-remove-id (doc-blocks doc) id) i blk))))))
;; ── op constructors (data payload, reused by persist op log) ──
(define op-insert (fn (block after) {:after after :op "insert" :block block}))
(define op-update (fn (id field value) {:field field :id id :op "update" :value value}))
(define op-move (fn (id index) {:id id :op "move" :index index}))
(define op-delete (fn (id) {:id id :op "delete"}))
;; ── op interpreter ──
(define
doc-apply
(fn
(doc op)
(let
((kind (get op :op)))
(cond
((= kind "insert")
(doc-insert-after doc (get op :block) (get op :after)))
((= kind "update")
(doc-update doc (get op :id) (get op :field) (get op :value)))
((= kind "move") (doc-move doc (get op :id) (get op :index)))
((= kind "delete") (doc-delete doc (get op :id)))
(else (error (str "unknown op: " kind)))))))
(define
doc-apply-all
(fn
(doc ops)
(if
(= (len ops) 0)
doc
(doc-apply-all (doc-apply doc (first ops)) (rest ops)))))
;; ── render-agnostic snapshot: list of (id . type) for assertions/debug ──
(define doc-ids (fn (doc) (map (fn (b) (blk-id b)) (doc-blocks doc))))
(define
doc-types
(fn (doc) (map (fn (b) (blk-type b)) (doc-blocks doc))))

68
lib/content/fed.sx Normal file
View File

@@ -0,0 +1,68 @@
;; content-on-sx — federated documents: trust-gated peer-authored ops.
;;
;; A peer-authored op carries provenance (:author, and a :sig stub). We never
;; auto-accept: a peer op is applied only if it passes a trust gate. The gate is
;; a predicate (fn op -> bool) so acl-on-sx can inject real trust facts later;
;; the convenience form takes an explicit trusted-actor list (the stub).
;;
;; Accepted ops flow through the CvRDT merge (Phase 3), so concurrent local and
;; external edits reconcile deterministically (same-field LWW, order-independent).
;;
;; Requires (loaded by harness): crdt.sx (and its deps).
;; tag an op with provenance
(define content/authored (fn (op author) (assoc op :author author)))
(define
content/signed
(fn (op author sig) (assoc (assoc op :author author) :sig sig)))
;; explicit trust stub: membership in a trusted-actor list
(define content/trusted? (fn (trust author) (crdt-member? author trust)))
;; general form: accept? is a predicate (fn op -> bool). Applies accepted ops
;; through the CRDT; quarantines the rest. Returns
;; {:state :accepted (ops) :rejected (ops)}.
(define
content/-merge-peer-loop
(fn
(state accept? ops accepted rejected)
(if
(= (len ops) 0)
{:state state :accepted (reverse accepted) :rejected (reverse rejected)}
(let
((op (first ops)))
(if
(accept? op)
(content/-merge-peer-loop
(crdt-apply state op)
accept?
(rest ops)
(cons op accepted)
rejected)
(content/-merge-peer-loop
state
accept?
(rest ops)
accepted
(cons op rejected)))))))
(define
content/merge-peer-with
(fn
(state accept? ops)
(content/-merge-peer-loop state accept? ops (list) (list))))
;; convenience: trust = list of trusted actor ids
(define
content/merge-peer
(fn
(state trust ops)
(content/merge-peer-with
state
(fn (op) (content/trusted? trust (get op :author)))
ops)))
(define content/accepted (fn (res) (get res :accepted)))
(define content/rejected (fn (res) (get res :rejected)))
(define content/peer-state (fn (res) (get res :state)))

View File

@@ -0,0 +1,31 @@
;; content-on-sx — global find/replace across text-bearing blocks.
;;
;; Replaces every occurrence of `from` with `to` in the text field of text /
;; heading / code / quote blocks, tree-wide (via the transform layer). For
;; renaming a term throughout a document. Immutable; case-sensitive.
;;
;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks).
(define
fr-in?
(fn
(x xs)
(cond
((= (len xs) 0) false)
((= (first xs) x) true)
(else (fr-in? x (rest xs))))))
(define
fr-has-text?
(fn (b) (fr-in? (blk-type b) (list "text" "heading" "code" "quote"))))
(define
content/find-replace
(fn
(doc from to)
(content/map-blocks
doc
fr-has-text?
(fn
(b)
(blk-set b "text" (replace (str (blk-get b "text")) from to))))))

34
lib/content/flatten.sx Normal file
View File

@@ -0,0 +1,34 @@
;; content-on-sx — document flatten.
;;
;; Un-nests a sectioned document into a flat block sequence: each section is
;; replaced inline by its (recursively flattened) children, dropping the section
;; wrapper. The inverse of content/wrap-section, for flat export targets.
;; Immutable; inline tree handling (no section.sx dep).
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define
flat-section?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define
flat-blocks
(fn
(blocks)
(if
(= (len blocks) 0)
(list)
(let
((b (first blocks)))
(append
(if
(flat-section? b)
(let
((ch (st-iv-get b "children")))
(if (list? ch) (flat-blocks ch) (list)))
(list b))
(flat-blocks (rest blocks)))))))
(define
content/flatten
(fn (doc) (doc-with-blocks doc (flat-blocks (doc-blocks doc)))))

51
lib/content/index.sx Normal file
View File

@@ -0,0 +1,51 @@
;; content-on-sx — multi-document index.
;;
;; Projects a list of documents into summary cards (the blog index page), with
;; tag filtering (category pages) and a tag cloud. Composes content/summary +
;; doc metadata.
;;
;; Requires (loaded by harness): summary.sx (content/summary), meta.sx (doc-tags).
(define
idx-in?
(fn
(x xs)
(cond
((= (len xs) 0) false)
((= (first xs) x) true)
(else (idx-in? x (rest xs))))))
(define
idx-dedup
(fn
(xs seen)
(if
(= (len xs) 0)
(reverse seen)
(if
(idx-in? (first xs) seen)
(idx-dedup (rest xs) seen)
(idx-dedup (rest xs) (cons (first xs) seen))))))
(define content/index (fn (docs) (map content/summary docs)))
(define content/has-tag? (fn (doc tag) (idx-in? tag (doc-tags doc))))
(define
content/index-by-tag
(fn
(docs tag)
(map content/summary (filter (fn (d) (content/has-tag? d tag)) docs))))
(define
content/all-tags
(fn (docs) (idx-dedup (ct-flatmap-tags docs) (list))))
(define
ct-flatmap-tags
(fn
(docs)
(if
(= (len docs) 0)
(list)
(append (doc-tags (first docs)) (ct-flatmap-tags (rest docs))))))

55
lib/content/markdown.sx Normal file
View File

@@ -0,0 +1,55 @@
;; content-on-sx — Markdown render mode.
;;
;; A third boundary format alongside asHTML / asSx, via the same polymorphic
;; dispatch. The newline is supplied by the boundary as a keyword arg
;; (asMarkdown: nl) because this Smalltalk dialect has no Character newline
;; constructor — blocks that need internal newlines (code, lists, doc) use it.
;;
;; No Markdown escaping yet (Markdown's escaping rules differ from HTML); raw
;; text is emitted. Ordered lists emit "1." for every item (Markdown renumbers).
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define
content-bootstrap-markdown!
(fn
()
(begin
(ct-def-method!
"CtHeading"
"asMarkdown:"
"asMarkdown: nl | h i | h := ''. i := 0. [i < level] whileTrue: [h := h , '#'. i := i + 1]. ^ h , ' ' , text")
(ct-def-method! "CtText" "asMarkdown:" "asMarkdown: nl ^ text")
(ct-def-method!
"CtCode"
"asMarkdown:"
"asMarkdown: nl ^ '```' , language , nl , text , nl , '```'")
(ct-def-method! "CtQuote" "asMarkdown:" "asMarkdown: nl ^ '> ' , text")
(ct-def-method!
"CtImage"
"asMarkdown:"
"asMarkdown: nl ^ '![' , alt , '](' , src , ')'")
(ct-def-method!
"CtEmbed"
"asMarkdown:"
"asMarkdown: nl ^ '[embed](' , url , ')'")
(ct-def-method! "CtDivider" "asMarkdown:" "asMarkdown: nl ^ '---'")
(ct-def-method!
"CtList"
"asMarkdown:"
"asMarkdown: nl | mark | mark := ordered ifTrue: ['1. '] ifFalse: ['- ']. ^ (items inject: '' into: [:a :x | a , (a = '' ifTrue: [''] ifFalse: [nl]) , mark , x])")
(ct-def-method!
"CtDoc"
"asMarkdown:"
"asMarkdown: nl ^ (blocks inject: '' into: [:a :b | a , (a = '' ifTrue: [''] ifFalse: [nl , nl]) , (b asMarkdown: nl)])")
true)))
(define ct-nl (str "\n"))
;; ── SX boundary ──
(define
asMarkdown
(fn (node) (str (st-send node "asMarkdown:" (list ct-nl)))))
(define content/markdown asMarkdown)
(define render-markdown asMarkdown)
(define block-markdown asMarkdown)

63
lib/content/md-doc.sx Normal file
View File

@@ -0,0 +1,63 @@
;; content-on-sx — Markdown document export (frontmatter + body).
;;
;; content/markdown-doc emits a YAML-ish --- frontmatter block from the document
;; metadata (title/slug/tags) followed by the Markdown body, completing the
;; metadata round-trip with md/import (md/import ∘ content/markdown-doc keeps
;; title/slug/tags). With no metadata it is just asMarkdown.
;;
;; Requires (loaded by harness): doc.sx, meta.sx (doc-title/slug/tags),
;; markdown.sx (asMarkdown).
(define mdd-nl (str "\n"))
(define
mdd-join
(fn
(sep parts)
(cond
((= (len parts) 0) "")
((= (len parts) 1) (first parts))
(else (str (first parts) sep (mdd-join sep (rest parts)))))))
(define
content/-fm-parts
(fn
(doc)
(append
(append
(if
(= (doc-title doc) nil)
(list)
(list (str "title: " (doc-title doc))))
(if
(= (doc-slug doc) nil)
(list)
(list (str "slug: " (doc-slug doc)))))
(let
((tags (doc-tags doc)))
(if
(= (len tags) 0)
(list)
(list (str "tags: " (mdd-join ", " tags))))))))
(define
content/-frontmatter
(fn
(doc)
(let
((parts (content/-fm-parts doc)))
(if
(= (len parts) 0)
""
(str "---" mdd-nl (mdd-join mdd-nl parts) mdd-nl "---")))))
(define
content/markdown-doc
(fn
(doc)
(let
((fm (content/-frontmatter doc)))
(if
(= fm "")
(asMarkdown doc)
(str fm mdd-nl mdd-nl (asMarkdown doc))))))

449
lib/content/md-import.sx Normal file
View File

@@ -0,0 +1,449 @@
;; content-on-sx — Markdown import adapter (markdown text -> block document).
;;
;; A line-based parser, the inverse of markdown.sx's asMarkdown. Confined to the
;; adapter boundary: the core knows nothing about Markdown. Handles a leading
;; --- frontmatter block (key: value -> doc metadata), ATX headings (#..######),
;; fenced code (```lang), blockquotes (> ), unordered (- / * ) and ordered (1. )
;; lists, thematic breaks (--- / ***), pipe tables (header + --- separator +
;; body), and paragraphs (consecutive plain lines joined with a space). Block ids
;; are assigned sequentially b0,b1…
;;
;; Requires (loaded by harness): block.sx, doc.sx, table.sx (mk-table),
;; meta.sx (doc-with-meta); markdown.sx for the adapter's export side.
(define md/-id (fn (i) (str "b" i)))
(define md/-blank? (fn (s) (= s "")))
(define md/-hr? (fn (s) (if (= s "---") true (= s "***"))))
(define
ct-in?
(fn
(x xs)
(cond
((= (len xs) 0) false)
((= (first xs) x) true)
(else (ct-in? x (rest xs))))))
(define
ct-starts-with?
(fn
(s prefix)
(and
(>= (string-length s) (string-length prefix))
(= (substring s 0 (string-length prefix)) prefix))))
(define
md/-drop
(fn (s prefix) (substring s (string-length prefix) (string-length s))))
(define
md/-drop-n
(fn
(xs n)
(if
(= n 0)
xs
(if
(= (len xs) 0)
xs
(md/-drop-n (rest xs) (- n 1))))))
(define
md/-join-with
(fn
(sep parts)
(cond
((= (len parts) 0) "")
((= (len parts) 1) (first parts))
(else (str (first parts) sep (md/-join-with sep (rest parts)))))))
(define md/-join-sp (fn (parts) (md/-join-with " " parts)))
(define md/-join-nl (fn (parts) (md/-join-with (str "\n") parts)))
;; ── heading detection (leading #s then a space) ──
(define
md/-hashes
(fn
(s n)
(if
(and
(< n (string-length s))
(= (substring s n (+ n 1)) "#"))
(md/-hashes s (+ n 1))
n)))
(define
md/-heading?
(fn
(line)
(let
((n (md/-hashes line 0)))
(and
(> n 0)
(<= n 6)
(> (string-length line) n)
(= (substring line n (+ n 1)) " ")))))
(define
md/-heading-block
(fn
(line i)
(let
((n (md/-hashes line 0)))
(mk-heading
(md/-id i)
n
(substring line (+ n 1) (string-length line))))))
;; ── list detection ──
(define
ct-digit?
(fn (ch) (ct-in? ch (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))))
(define
md/-digits
(fn
(s n)
(if
(and
(< n (string-length s))
(ct-digit? (substring s n (+ n 1))))
(md/-digits s (+ n 1))
n)))
(define
md/-ol?
(fn
(line)
(let
((n (md/-digits line 0)))
(and
(> n 0)
(>= (string-length line) (+ n 2))
(= (substring line n (+ n 2)) ". ")))))
(define
md/-drop-ol
(fn
(line)
(let
((n (md/-digits line 0)))
(substring line (+ n 2) (string-length line)))))
(define
md/-ul?
(fn
(line)
(if (ct-starts-with? line "- ") true (ct-starts-with? line "* "))))
(define
md/-drop-ul
(fn (line) (substring line 2 (string-length line))))
;; ── table detection ──
(define md/-pipe-row? (fn (line) (ct-starts-with? (trim line) "|")))
(define md/-sep-char? (fn (ch) (ct-in? ch (list "-" ":" "|" " "))))
(define
md/-all-sep?
(fn
(s i)
(if
(>= i (string-length s))
true
(if
(md/-sep-char? (substring s i (+ i 1)))
(md/-all-sep? s (+ i 1))
false))))
(define
md/-has-dash?
(fn
(s i)
(if
(>= i (string-length s))
false
(if
(= (substring s i (+ i 1)) "-")
true
(md/-has-dash? s (+ i 1))))))
(define
md/-sep-row?
(fn
(line)
(and
(md/-pipe-row? line)
(md/-all-sep? (trim line) 0)
(md/-has-dash? line 0))))
(define
md/-table-start?
(fn
(lines)
(and
(md/-pipe-row? (first lines))
(> (len lines) 1)
(md/-sep-row? (nth lines 1)))))
(define
md/-strip-pipes
(fn
(s0)
(let
((s (trim s0)))
(let
((a (if (ct-starts-with? s "|") (substring s 1 (string-length s)) s)))
(if
(and
(> (string-length a) 0)
(=
(substring
a
(- (string-length a) 1)
(string-length a))
"|"))
(substring a 0 (- (string-length a) 1))
a)))))
(define
md/-cells
(fn (line) (map (fn (c) (trim c)) (split (md/-strip-pipes line) "|"))))
(define
md/-plain?
(fn
(line)
(if
(md/-blank? line)
false
(if
(ct-starts-with? line "```")
false
(if
(md/-heading? line)
false
(if
(ct-starts-with? line "> ")
false
(if
(md/-hr? line)
false
(if (md/-ul? line) false (if (md/-ol? line) false true)))))))))
;; ── multi-line collectors ──
(define
md/-code
(fn
(lines i acc)
(md/-code-collect
(rest lines)
(md/-drop (first lines) "```")
(list)
i
acc)))
(define
md/-code-collect
(fn
(lines lang body i acc)
(cond
((= (len lines) 0)
(md/-walk
lines
(+ i 1)
(cons (mk-code (md/-id i) lang (md/-join-nl (reverse body))) acc)))
((= (first lines) "```")
(md/-walk
(rest lines)
(+ i 1)
(cons (mk-code (md/-id i) lang (md/-join-nl (reverse body))) acc)))
(else
(md/-code-collect (rest lines) lang (cons (first lines) body) i acc)))))
(define
md/-table-body
(fn
(lines headers rows i acc)
(if
(= (len lines) 0)
(md/-walk
lines
(+ i 1)
(cons (mk-table (md/-id i) headers (reverse rows)) acc))
(let
((line (first lines)))
(if
(md/-pipe-row? line)
(md/-table-body
(rest lines)
headers
(cons (md/-cells line) rows)
i
acc)
(md/-walk
lines
(+ i 1)
(cons (mk-table (md/-id i) headers (reverse rows)) acc)))))))
(define
md/-table
(fn
(lines i acc)
(md/-table-body
(rest (rest lines))
(md/-cells (first lines))
(list)
i
acc)))
(define
md/-list-collect
(fn
(lines items i acc ordered)
(if
(= (len lines) 0)
(md/-walk
lines
(+ i 1)
(cons (mk-list (md/-id i) ordered (reverse items)) acc))
(let
((line (first lines)))
(cond
(ordered
(if
(md/-ol? line)
(md/-list-collect
(rest lines)
(cons (md/-drop-ol line) items)
i
acc
ordered)
(md/-walk
lines
(+ i 1)
(cons (mk-list (md/-id i) ordered (reverse items)) acc))))
(else
(if
(md/-ul? line)
(md/-list-collect
(rest lines)
(cons (md/-drop-ul line) items)
i
acc
ordered)
(md/-walk
lines
(+ i 1)
(cons (mk-list (md/-id i) ordered (reverse items)) acc)))))))))
(define
md/-para-collect
(fn
(lines parts i acc)
(if
(= (len lines) 0)
(md/-walk
lines
(+ i 1)
(cons (mk-text (md/-id i) (md/-join-sp (reverse parts))) acc))
(let
((line (first lines)))
(if
(md/-plain? line)
(md/-para-collect (rest lines) (cons line parts) i acc)
(md/-walk
lines
(+ i 1)
(cons (mk-text (md/-id i) (md/-join-sp (reverse parts))) acc)))))))
;; ── main walk ──
(define
md/-walk
(fn
(lines i acc)
(if
(= (len lines) 0)
(reverse acc)
(let
((line (first lines)))
(cond
((md/-blank? line) (md/-walk (rest lines) i acc))
((ct-starts-with? line "```") (md/-code lines i acc))
((md/-heading? line)
(md/-walk
(rest lines)
(+ i 1)
(cons (md/-heading-block line i) acc)))
((ct-starts-with? line "> ")
(md/-walk
(rest lines)
(+ i 1)
(cons (mk-quote (md/-id i) "" (md/-drop line "> ")) acc)))
((md/-hr? line)
(md/-walk
(rest lines)
(+ i 1)
(cons (mk-divider (md/-id i)) acc)))
((md/-table-start? lines) (md/-table lines i acc))
((md/-ul? line) (md/-list-collect lines (list) i acc false))
((md/-ol? line) (md/-list-collect lines (list) i acc true))
(else (md/-para-collect lines (list) i acc)))))))
(define
md/parse
(fn (text) (md/-walk (split text (str "\n")) 0 (list))))
;; ── frontmatter (leading --- key: value --- block) ──
(define
md/-frontmatter?
(fn (lines) (and (> (len lines) 0) (= (first lines) "---"))))
(define
md/-fm-end
(fn
(lines i)
(cond
((>= i (len lines)) -1)
((= (nth lines i) "---") i)
(else (md/-fm-end lines (+ i 1))))))
(define
md/-fm-add
(fn
(acc line)
(let
((parts (split line ":")))
(if
(< (len parts) 2)
acc
(let
((key (trim (first parts)))
(val (trim (md/-join-with ":" (rest parts)))))
(cond
((= key "title") (assoc acc :title val))
((= key "slug") (assoc acc :slug val))
((= key "tags")
(assoc acc :tags (map (fn (t) (trim t)) (split val ","))))
(else acc)))))))
(define
md/-fm-pairs
(fn
(lines start end acc)
(if
(>= start end)
acc
(md/-fm-pairs
lines
(+ start 1)
end
(md/-fm-add acc (nth lines start))))))
;; ── adapter ──
(define
md/import
(fn
(text doc-id)
(let
((lines (split text (str "\n"))))
(if
(md/-frontmatter? lines)
(let
((end (md/-fm-end lines 1)))
(if
(= end -1)
(doc-new doc-id (md/-walk lines 0 (list)))
(doc-with-meta
(doc-new
doc-id
(md/-walk
(md/-drop-n lines (+ end 1))
0
(list)))
(md/-fm-pairs lines 1 end {}))))
(doc-new doc-id (md/-walk lines 0 (list)))))))
(define content/from-markdown md/import)
(define markdown-adapter {:export (fn (doc) (asMarkdown doc)) :import md/import})

52
lib/content/media.sx Normal file
View File

@@ -0,0 +1,52 @@
;; content-on-sx — video/audio media block.
;;
;; CtMedia holds a `kind` (video/audio) and `src`. Self-contained: answers
;; asHTML/asSx/asText/asMarkdown: so it composes with the render boundary with no
;; changes elsewhere. HTML src is htmlEscaped, SX src sxEscaped.
;;
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (escapers);
;; markdown.sx / text.sx for those formats.
(define
content-bootstrap-media!
(fn
()
(begin
(st-class-define! "CtMedia" "CtBlock" (list "kind" "src"))
(ct-def-method! "CtMedia" "kind" "kind ^ kind")
(ct-def-method! "CtMedia" "src" "src ^ src")
(ct-def-method! "CtMedia" "type" "type ^ #media")
(ct-def-method!
"CtMedia"
"asHTML"
"asHTML ^ '<' , kind , ' src=\"' , src htmlEscaped , '\" controls></' , kind , '>'")
(ct-def-method!
"CtMedia"
"asSx"
"asSx ^ '(' , kind , ' :src \"' , src sxEscaped , '\")'")
(ct-def-method! "CtMedia" "asText" "asText ^ ''")
(ct-def-method!
"CtMedia"
"asMarkdown:"
"asMarkdown: nl ^ '[' , kind , '](' , src , ')'")
true)))
(define
mk-media
(fn
(id kind src)
(st-iv-set!
(st-iv-set!
(st-iv-set! (st-make-instance "CtMedia") "id" id)
"kind"
kind)
"src"
src)))
(define
media?
(fn (b) (and (st-instance? b) (= (get b :class) "CtMedia"))))
(define media-kind (fn (b) (st-send b "kind" (list))))
(define mk-video (fn (id src) (mk-media id "video" src)))
(define mk-audio (fn (id src) (mk-media id "audio" src)))

53
lib/content/meta.sx Normal file
View File

@@ -0,0 +1,53 @@
;; content-on-sx — document metadata (title / slug / tags).
;;
;; CtDoc carries optional metadata alongside its blocks (ivars declared in
;; doc.sx). Reads go through message dispatch; setters are copy-on-write
;; (functional st-iv-set!), consistent with the immutable document model.
;;
;; Requires (loaded by harness): block.sx, doc.sx.
;; ── reads ──
(define doc-title (fn (doc) (st-send doc "title" (list))))
(define doc-slug (fn (doc) (st-send doc "slug" (list))))
(define
doc-tags
(fn
(doc)
(let ((t (st-send doc "tags" (list)))) (if (= t nil) (list) t))))
(define doc-meta (fn (doc) {:slug (doc-slug doc) :id (doc-id doc) :title (doc-title doc) :tags (doc-tags doc)}))
;; ── copy-on-write setters ──
(define doc-with-title (fn (doc title) (st-iv-set! doc "title" title)))
(define doc-with-slug (fn (doc slug) (st-iv-set! doc "slug" slug)))
(define doc-with-tags (fn (doc tags) (st-iv-set! doc "tags" tags)))
(define
doc-add-tag
(fn (doc tag) (doc-with-tags doc (append (doc-tags doc) (list tag)))))
;; set several at once: meta is a dict with optional :title :slug :tags
(define
doc-with-meta
(fn
(doc meta)
(let
((d1 (if (has-key? meta :title) (doc-with-title doc (get meta :title)) doc)))
(let
((d2 (if (has-key? meta :slug) (doc-with-slug d1 (get meta :slug)) d1)))
(if (has-key? meta :tags) (doc-with-tags d2 (get meta :tags)) d2)))))
;; constructor with metadata
(define
doc-new-meta
(fn (id blocks meta) (doc-with-meta (doc-new id blocks) meta)))
;; ── content/* facade aliases ──
(define content/title doc-title)
(define content/slug doc-slug)
(define content/tags doc-tags)
(define content/meta doc-meta)
(define content/with-title doc-with-title)
(define content/with-slug doc-with-slug)
(define content/with-tags doc-with-tags)
(define content/with-meta doc-with-meta)

69
lib/content/move.sx Normal file
View File

@@ -0,0 +1,69 @@
;; content-on-sx — relative block reorder.
;;
;; Move a top-level block to just before / after another block by id — more
;; ergonomic than the index-based doc-move. No-op if either id is missing.
;; Immutable; composes the doc.sx list helpers.
;;
;; Requires (loaded by harness): doc.sx.
(define
content/move-before
(fn
(doc id target)
(let
((blk (doc-find doc id)))
(if
(= blk nil)
doc
(let
((without (ct-remove-id (doc-blocks doc) id)))
(let
((idx (ct-index-of without target)))
(if
(= idx -1)
doc
(doc-with-blocks doc (ct-insert-at without idx blk)))))))))
(define
content/move-after
(fn
(doc id target)
(let
((blk (doc-find doc id)))
(if
(= blk nil)
doc
(let
((without (ct-remove-id (doc-blocks doc) id)))
(let
((idx (ct-index-of without target)))
(if
(= idx -1)
doc
(doc-with-blocks
doc
(ct-insert-at without (+ idx 1) blk)))))))))
(define
content/move-to-front
(fn
(doc id)
(let
((blk (doc-find doc id)))
(if
(= blk nil)
doc
(doc-with-blocks doc (cons blk (ct-remove-id (doc-blocks doc) id)))))))
(define
content/move-to-back
(fn
(doc id)
(let
((blk (doc-find doc id)))
(if
(= blk nil)
doc
(doc-with-blocks
doc
(append (ct-remove-id (doc-blocks doc) id) (list blk)))))))

49
lib/content/normalize.sx Normal file
View File

@@ -0,0 +1,49 @@
;; content-on-sx — document normalization.
;;
;; A cleanup pass: drop empty text blocks and empty sections across the tree.
;; Sections are normalised first, so a section that becomes empty (all children
;; dropped) is itself dropped. For tidying imported/edited documents. Immutable.
;; Inline tree handling (no section.sx dep).
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define
norm-section?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define
norm-empty-text?
(fn (b) (and (= (blk-type b) "text") (= (str (blk-get b "text")) ""))))
(define
norm-empty-section?
(fn
(b)
(and
(norm-section? b)
(let
((ch (st-iv-get b "children")))
(or (= ch nil) (= (len ch) 0))))))
(define
norm-recurse
(fn
(b)
(if
(norm-section? b)
(let
((ch (st-iv-get b "children")))
(if (list? ch) (st-iv-set! b "children" (norm-blocks ch)) b))
b)))
(define
norm-keep?
(fn
(b)
(if (norm-empty-text? b) false (if (norm-empty-section? b) false true))))
(define
norm-blocks
(fn (blocks) (filter norm-keep? (map norm-recurse blocks))))
(define
content/normalize
(fn (doc) (doc-with-blocks doc (norm-blocks (doc-blocks doc)))))

34
lib/content/outline.sx Normal file
View File

@@ -0,0 +1,34 @@
;; content-on-sx — nested document outline.
;;
;; Builds a hierarchical heading tree from content/headings: each node is
;; {:id :text :level :children}, where a heading nests under the nearest
;; preceding heading of a lower level. The structured companion to the flat TOC,
;; for rendering nested navigation.
;;
;; Requires (loaded by harness): query.sx (content/headings).
;; consume a prefix of `hs` forming nodes whose level > minlevel; return
;; {:nodes ... :rest ...}.
(define
ol-forest
(fn
(hs minlevel)
(if
(= (len hs) 0)
{:rest (list) :nodes (list)}
(let
((h (first hs)))
(if
(<= (get h :level) minlevel)
{:rest hs :nodes (list)}
(let
((sub (ol-forest (rest hs) (get h :level))))
(let
((node {:id (get h :id) :text (get h :text) :children (get sub :nodes) :level (get h :level)}))
(let
((more (ol-forest (get sub :rest) minlevel)))
{:rest (get more :rest) :nodes (cons node (get more :nodes))}))))))))
(define
content/outline
(fn (doc) (get (ol-forest (content/headings doc) 0) :nodes)))

23
lib/content/page-full.sx Normal file
View File

@@ -0,0 +1,23 @@
;; content-on-sx — SEO-complete HTML page.
;;
;; content/page-full extends content/page with a lang attribute and a
;; <meta name="description"> drawn from the document excerpt (plain text,
;; truncated). Composes the page, metadata and text layers.
;;
;; Requires (loaded by harness): page.sx (ct-html-escape, content/page-title),
;; text.sx (content/excerpt), render.sx (asHTML).
(define CONTENT-EXCERPT-LEN 160)
(define
content/page-full
(fn
(doc)
(str
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>"
(ct-html-escape (content/page-title doc))
"</title><meta name=\"description\" content=\""
(ct-html-escape (content/excerpt doc CONTENT-EXCERPT-LEN))
"\"></head><body>"
(asHTML doc)
"</body></html>")))

26
lib/content/page.sx Normal file
View File

@@ -0,0 +1,26 @@
;; content-on-sx — full HTML page wrapper.
;;
;; content/page composes the metadata + render layers into the shippable
;; artifact the blog serves: a minimal valid HTML5 document with an escaped
;; <title> (from doc metadata, falling back to the id) and the rendered blocks
;; as the body.
;;
;; Requires (loaded by harness): doc.sx, render.sx (asHTML + htmlEscaped),
;; meta.sx (doc-title).
(define ct-html-escape (fn (s) (str (st-send s "htmlEscaped" (list)))))
(define
content/page-title
(fn (doc) (let ((t (doc-title doc))) (if (= t nil) (doc-id doc) t))))
(define
content/page
(fn
(doc)
(str
"<!doctype html><html><head><meta charset=\"utf-8\"><title>"
(ct-html-escape (content/page-title doc))
"</title></head><body>"
(asHTML doc)
"</body></html>")))

51
lib/content/query.sx Normal file
View File

@@ -0,0 +1,51 @@
;; content-on-sx — block query + table of contents.
;;
;; Collect blocks across the whole tree (descending into sections) by predicate
;; or type, and derive a table of contents from headings. Tree detection is
;; inline (class + st-iv-get) so this needs no section.sx.
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define
qry-section?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define
qry-tree
(fn
(blocks)
(if
(= (len blocks) 0)
(list)
(let
((b (first blocks)))
(append
(cons
b
(if
(qry-section? b)
(let
((ch (st-iv-get b "children")))
(if (list? ch) (qry-tree ch) (list)))
(list)))
(qry-tree (rest blocks)))))))
(define
content/select
(fn (doc pred) (filter pred (qry-tree (doc-blocks doc)))))
(define
content/select-type
(fn (doc type) (content/select doc (fn (b) (= (blk-type b) type)))))
(define
content/count-type
(fn (doc type) (len (content/select-type doc type))))
(define
content/select-ids
(fn (doc pred) (map (fn (b) (blk-id b)) (content/select doc pred))))
;; table of contents: {:id :level :text} for every heading, in document order.
(define
content/headings
(fn (doc) (map (fn (b) {:id (blk-id b) :text (blk-get b "text") :level (blk-get b "level")}) (content/select-type doc "heading"))))

99
lib/content/render.sx Normal file
View File

@@ -0,0 +1,99 @@
;; content-on-sx — render boundary.
;;
;; Rendering is a message, not a property switch: every block (and the document)
;; answers asHTML and asSx. The internal model carries no presentation — the
;; boundary format is chosen by which message you send. The document folds its
;; children's renderings, so (asHTML doc) / (asSx doc) are pure polymorphic
;; sends with no type dispatch in the SX layer.
;;
;; Escaping happens HERE, at the boundary. asHTML routes text/attrs through
;; String>>htmlEscaped (& < > "); asSx routes them through String>>sxEscaped
;; (\ and ") so values cannot break out of an element or an SX string literal.
(define
content-bootstrap-render!
(fn
()
(begin
(ct-def-method!
"String"
"htmlEscaped"
"htmlEscaped | out i n c | out := ''. n := self size. i := 1. [i <= n] whileTrue: [c := self at: i. (c = $&) ifTrue: [out := out , '&amp;'] ifFalse: [(c = $<) ifTrue: [out := out , '&lt;'] ifFalse: [(c = $>) ifTrue: [out := out , '&gt;'] ifFalse: [(c = $\") ifTrue: [out := out , '&quot;'] ifFalse: [out := out , c asString]]]]. i := i + 1]. ^ out")
(ct-def-method!
"String"
"sxEscaped"
"sxEscaped | out i n c | out := ''. n := self size. i := 1. [i <= n] whileTrue: [c := self at: i. (c = $\\) ifTrue: [out := out , '\\\\'] ifFalse: [(c = $\") ifTrue: [out := out , '\\\"'] ifFalse: [out := out , c asString]]. i := i + 1]. ^ out")
(ct-def-method!
"CtHeading"
"asHTML"
"asHTML | t | t := level printString. ^ '<h' , t , '>' , text htmlEscaped , '</h' , t , '>'")
(ct-def-method!
"CtText"
"asHTML"
"asHTML ^ '<p>' , text htmlEscaped , '</p>'")
(ct-def-method!
"CtCode"
"asHTML"
"asHTML ^ '<pre><code class=\"language-' , language htmlEscaped , '\">' , text htmlEscaped , '</code></pre>'")
(ct-def-method!
"CtQuote"
"asHTML"
"asHTML ^ '<blockquote>' , text htmlEscaped , '</blockquote>'")
(ct-def-method!
"CtImage"
"asHTML"
"asHTML ^ '<img src=\"' , src htmlEscaped , '\" alt=\"' , alt htmlEscaped , '\">'")
(ct-def-method!
"CtEmbed"
"asHTML"
"asHTML ^ '<iframe src=\"' , url htmlEscaped , '\"></iframe>'")
(ct-def-method! "CtDivider" "asHTML" "asHTML ^ '<hr>'")
(ct-def-method!
"CtList"
"asHTML"
"asHTML | tag | tag := ordered ifTrue: ['ol'] ifFalse: ['ul']. ^ '<' , tag , '>' , (items inject: '' into: [:a :x | a , '<li>' , x htmlEscaped , '</li>']) , '</' , tag , '>'")
(ct-def-method!
"CtDoc"
"asHTML"
"asHTML ^ blocks inject: '' into: [:a :b | a , (b asHTML)]")
(ct-def-method!
"CtHeading"
"asSx"
"asSx | t | t := level printString. ^ '(h' , t , ' \"' , text sxEscaped , '\")'")
(ct-def-method! "CtText" "asSx" "asSx ^ '(p \"' , text sxEscaped , '\")'")
(ct-def-method!
"CtCode"
"asSx"
"asSx ^ '(pre (code \"' , text sxEscaped , '\"))'")
(ct-def-method!
"CtQuote"
"asSx"
"asSx ^ '(blockquote \"' , text sxEscaped , '\")'")
(ct-def-method!
"CtImage"
"asSx"
"asSx ^ '(img :src \"' , src sxEscaped , '\" :alt \"' , alt sxEscaped , '\")'")
(ct-def-method!
"CtEmbed"
"asSx"
"asSx ^ '(iframe :src \"' , url sxEscaped , '\")'")
(ct-def-method! "CtDivider" "asSx" "asSx ^ '(hr)'")
(ct-def-method!
"CtList"
"asSx"
"asSx | tag | tag := ordered ifTrue: ['ol'] ifFalse: ['ul']. ^ '(' , tag , ' ' , (items inject: '' into: [:a :x | a , '(li \"' , x sxEscaped , '\")']) , ')'")
(ct-def-method!
"CtDoc"
"asSx"
"asSx ^ '(article ' , (blocks inject: '' into: [:a :b | a , (b asSx)]) , ')'")
true)))
;; ── SX boundary API — pure message sends ──
(define asHTML (fn (node) (str (st-send node "asHTML" (list)))))
(define asSx (fn (node) (str (st-send node "asSx" (list)))))
;; readable aliases
(define render-html asHTML)
(define render-sx asSx)
(define block-html asHTML)
(define block-sx asSx)

View File

@@ -0,0 +1,48 @@
{
"suites": {
"block": {"pass": 38, "fail": 0},
"doc": {"pass": 40, "fail": 0},
"render": {"pass": 42, "fail": 0},
"api": {"pass": 26, "fail": 0},
"meta": {"pass": 27, "fail": 0},
"page": {"pass": 7, "fail": 0},
"page-full": {"pass": 4, "fail": 0},
"markdown": {"pass": 20, "fail": 0},
"text": {"pass": 20, "fail": 0},
"section": {"pass": 25, "fail": 0},
"compose": {"pass": 17, "fail": 0},
"tree-edit": {"pass": 17, "fail": 0},
"move": {"pass": 11, "fail": 0},
"clone": {"pass": 10, "fail": 0},
"query": {"pass": 13, "fail": 0},
"toc": {"pass": 8, "fail": 0},
"anchor": {"pass": 6, "fail": 0},
"outline": {"pass": 14, "fail": 0},
"flatten": {"pass": 10, "fail": 0},
"transform": {"pass": 12, "fail": 0},
"normalize": {"pass": 11, "fail": 0},
"find-replace": {"pass": 10, "fail": 0},
"stats": {"pass": 17, "fail": 0},
"summary": {"pass": 14, "fail": 0},
"index": {"pass": 13, "fail": 0},
"table": {"pass": 15, "fail": 0},
"callout": {"pass": 12, "fail": 0},
"media": {"pass": 15, "fail": 0},
"data": {"pass": 25, "fail": 0},
"wire": {"pass": 11, "fail": 0},
"validate": {"pass": 23, "fail": 0},
"store": {"pass": 29, "fail": 0},
"snapshot": {"pass": 20, "fail": 0},
"crdt": {"pass": 34, "fail": 0},
"crdt-tree": {"pass": 17, "fail": 0},
"crdt-blocks": {"pass": 7, "fail": 0},
"crdt-store": {"pass": 14, "fail": 0},
"sync": {"pass": 14, "fail": 0},
"md-import": {"pass": 38, "fail": 0},
"md-doc": {"pass": 12, "fail": 0},
"fed": {"pass": 20, "fail": 0}
},
"total_pass": 738,
"total_fail": 0,
"total": 738
}

48
lib/content/scoreboard.md Normal file
View File

@@ -0,0 +1,48 @@
# content-on-sx Conformance Scoreboard
_Generated by `lib/content/conformance.sh`_
| Suite | Pass | Fail | Total |
|-------|-----:|-----:|------:|
| block | 38 | 0 | 38 |
| doc | 40 | 0 | 40 |
| render | 42 | 0 | 42 |
| api | 26 | 0 | 26 |
| meta | 27 | 0 | 27 |
| page | 7 | 0 | 7 |
| page-full | 4 | 0 | 4 |
| markdown | 20 | 0 | 20 |
| text | 20 | 0 | 20 |
| section | 25 | 0 | 25 |
| compose | 17 | 0 | 17 |
| tree-edit | 17 | 0 | 17 |
| move | 11 | 0 | 11 |
| clone | 10 | 0 | 10 |
| query | 13 | 0 | 13 |
| toc | 8 | 0 | 8 |
| anchor | 6 | 0 | 6 |
| outline | 14 | 0 | 14 |
| flatten | 10 | 0 | 10 |
| transform | 12 | 0 | 12 |
| normalize | 11 | 0 | 11 |
| find-replace | 10 | 0 | 10 |
| stats | 17 | 0 | 17 |
| summary | 14 | 0 | 14 |
| index | 13 | 0 | 13 |
| table | 15 | 0 | 15 |
| callout | 12 | 0 | 12 |
| media | 15 | 0 | 15 |
| data | 25 | 0 | 25 |
| wire | 11 | 0 | 11 |
| validate | 23 | 0 | 23 |
| store | 29 | 0 | 29 |
| snapshot | 20 | 0 | 20 |
| crdt | 34 | 0 | 34 |
| crdt-tree | 17 | 0 | 17 |
| crdt-blocks | 7 | 0 | 7 |
| crdt-store | 14 | 0 | 14 |
| sync | 14 | 0 | 14 |
| md-import | 38 | 0 | 38 |
| md-doc | 12 | 0 | 12 |
| fed | 20 | 0 | 20 |
| **Total** | **738** | **0** | **738** |

103
lib/content/section.sx Normal file
View File

@@ -0,0 +1,103 @@
;; content-on-sx — nested block trees (section container).
;;
;; CtSection is a block whose ivar `children` is an ordered list of blocks (any
;; type, including nested sections → arbitrary depth). This turns the document
;; from a flat sequence into the ordered TREE of the architecture sketch.
;;
;; Self-contained: CtSection answers asHTML/asSx/asText/asMarkdown: by folding
;; its children's renderings — pure polymorphic recursion, so it composes with
;; the existing render boundary with no changes to block.sx or render.sx. (The
;; relevant per-block render bootstrap must be loaded for the children.)
;;
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (asHTML/asSx);
;; markdown.sx / text.sx for those formats on children.
(define
content-bootstrap-section!
(fn
()
(begin
(st-class-define! "CtSection" "CtBlock" (list "children"))
(ct-def-method! "CtSection" "children" "children ^ children")
(ct-def-method! "CtSection" "type" "type ^ #section")
(ct-def-method!
"CtSection"
"asHTML"
"asHTML ^ '<section>' , (children inject: '' into: [:a :b | a , (b asHTML)]) , '</section>'")
(ct-def-method!
"CtSection"
"asSx"
"asSx ^ '(section ' , (children inject: '' into: [:a :b | a , (b asSx)]) , ')'")
(ct-def-method!
"CtSection"
"asText"
"asText ^ (children inject: '' into: [:a :b | (b asText = '') ifTrue: [a] ifFalse: [(a = '' ifTrue: [b asText] ifFalse: [a , ' ' , b asText])]])")
(ct-def-method!
"CtSection"
"asMarkdown:"
"asMarkdown: nl ^ (children inject: '' into: [:a :b | a , (a = '' ifTrue: [''] ifFalse: [nl , nl]) , (b asMarkdown: nl)])")
true)))
(define
mk-section
(fn
(id children)
(st-iv-set!
(st-iv-set! (st-make-instance "CtSection") "id" id)
"children"
children)))
(define
section?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define section-children (fn (sec) (st-send sec "children" (list))))
;; copy-on-write child edits (return a new section)
(define
section-with-children
(fn (sec children) (st-iv-set! sec "children" children)))
(define
section-append
(fn
(sec block)
(section-with-children sec (append (section-children sec) (list block)))))
;; ── tree traversal (descends into nested sections) ──
(define
block-deep-find
(fn
(blocks id)
(if
(= (len blocks) 0)
nil
(let
((b (first blocks)))
(if
(= (blk-id b) id)
b
(let
((nested (if (section? b) (block-deep-find (section-children b) id) nil)))
(if (= nested nil) (block-deep-find (rest blocks) id) nested)))))))
(define doc-deep-find (fn (doc id) (block-deep-find (doc-blocks doc) id)))
(define
block-tree-ids
(fn
(blocks)
(if
(= (len blocks) 0)
(list)
(let
((b (first blocks)))
(append
(cons
(blk-id b)
(if (section? b) (block-tree-ids (section-children b)) (list)))
(block-tree-ids (rest blocks)))))))
(define doc-tree-ids (fn (doc) (block-tree-ids (doc-blocks doc))))
(define block-tree-count (fn (blocks) (len (block-tree-ids blocks))))
(define doc-tree-count (fn (doc) (len (doc-tree-ids doc))))

90
lib/content/snapshot.sx Normal file
View File

@@ -0,0 +1,90 @@
;; content-on-sx — snapshot cache over the op-log replay.
;;
;; Snapshots are a CACHE, never primary state: the op log stays the source of
;; truth. A snapshot stores a materialised document at a sequence in the persist
;; KV; cached reads start from it and replay only the tail of ops, so they return
;; a document IDENTICAL to a full replay — just faster. Drop the snapshot and
;; nothing is lost.
;;
;; Requires (loaded by harness): store.sx (+ doc.sx, persist event/log/kv/api).
(define content/-snap-key (fn (doc-id) (str "content-snap:" doc-id)))
;; take a snapshot of the current head at the current version. Returns the seq.
(define
content/snapshot!
(fn
(b doc-id)
(let
((seq (content/version-count b doc-id)))
(begin (persist/kv-put b (content/-snap-key doc-id) {:doc (content/head b doc-id) :seq seq}) seq))))
(define
content/-snapshot
(fn
(b doc-id)
(if
(persist/kv-has? b (content/-snap-key doc-id))
(persist/kv-get b (content/-snap-key doc-id))
nil)))
(define
content/snapshot-seq
(fn
(b doc-id)
(let
((s (content/-snapshot b doc-id)))
(if (= s nil) 0 (get s :seq)))))
(define
content/has-snapshot?
(fn (b doc-id) (persist/kv-has? b (content/-snap-key doc-id))))
(define
content/drop-snapshot!
(fn (b doc-id) (persist/kv-delete b (content/-snap-key doc-id))))
;; ── cached reads (transparent: identical result to store.sx replay) ──
(define
content/-tail-ops
(fn
(b doc-id from to)
(map
(fn (ev) (persist/event-data ev))
(filter
(fn
(ev)
(and
(> (persist/event-seq ev) from)
(<= (persist/event-seq ev) to)))
(content/log b doc-id)))))
(define
content/head-cached
(fn
(b doc-id)
(let
((snap (content/-snapshot b doc-id)))
(if
(= snap nil)
(content/head b doc-id)
(doc-apply-all
(get snap :doc)
(content/-tail-ops
b
doc-id
(get snap :seq)
(content/version-count b doc-id)))))))
(define
content/at-cached
(fn
(b doc-id seq)
(let
((snap (content/-snapshot b doc-id)))
(if
(or (= snap nil) (< seq (get snap :seq)))
(content/at b doc-id seq)
(doc-apply-all
(get snap :doc)
(content/-tail-ops b doc-id (get snap :seq) seq))))))

49
lib/content/stats.sx Normal file
View File

@@ -0,0 +1,49 @@
;; content-on-sx — document statistics (word/char/block counts, reading time).
;;
;; Counts derive from the plain-text projection (asText, tree-accurate via
;; section recursion) and a tree block count (inline class check, so this needs
;; no section.sx). Reading time uses 200 wpm, rounded up.
;;
;; Requires (loaded by harness): block.sx, doc.sx, text.sx (asText).
(define
ct-words
(fn (s) (filter (fn (w) (if (= w "") false true)) (split s " "))))
(define ct-ceil-div (fn (a b) (quotient (+ a (- b 1)) b)))
(define
ct-stat-section?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define
ct-stat-count
(fn
(blocks)
(if
(= (len blocks) 0)
0
(let
((b (first blocks)))
(+
(+
1
(if
(ct-stat-section? b)
(let
((ch (st-iv-get b "children")))
(if (list? ch) (ct-stat-count ch) 0))
0))
(ct-stat-count (rest blocks)))))))
(define content/word-count (fn (doc) (len (ct-words (asText doc)))))
(define content/char-count (fn (doc) (string-length (asText doc))))
(define content/block-count (fn (doc) (ct-stat-count (doc-blocks doc))))
(define
content/reading-minutes
(fn
(doc)
(let
((w (content/word-count doc)))
(if (= w 0) 0 (ct-ceil-div w 200)))))
(define content/stats (fn (doc) {:blocks (content/block-count doc) :reading-minutes (content/reading-minutes doc) :words (content/word-count doc) :chars (content/char-count doc)}))

101
lib/content/store.sx Normal file
View File

@@ -0,0 +1,101 @@
;; content-on-sx — op log + versioning over the persist event stream.
;;
;; The op log is the source of truth. Editing a document = appending the edit op
;; as a persist event to the document's stream. Any version of the document is a
;; replay of its op stream up to a sequence number; the materialised doc is a
;; cache, never primary state.
;;
;; Requires (loaded by the harness): block.sx, doc.sx, and persist
;; (event/backend/log/kv/api). The persist backend `b` is opened by the caller
;; via (persist/open) and injected — content knows nothing about which backend.
(define content/-stream (fn (doc-id) (str "content:" doc-id)))
;; ── commit: append an edit op as an event. `at` is a caller-supplied logical
;; timestamp (Date.now is unavailable in-kernel). Returns the stored event. ──
(define
content/commit!
(fn
(b doc-id op at)
(persist/append b (content/-stream doc-id) (get op :op) at op)))
(define
content/commit-all!
(fn
(b doc-id ops at)
(if
(= (len ops) 0)
nil
(begin
(content/commit! b doc-id (first ops) at)
(content/commit-all! b doc-id (rest ops) at)))))
;; ── read the raw log / op stream ──
(define
content/log
(fn (b doc-id) (persist/read b (content/-stream doc-id))))
(define
content/ops
(fn
(b doc-id)
(map (fn (ev) (persist/event-data ev)) (content/log b doc-id))))
;; logical version count (highest seq assigned, survives compaction)
(define
content/version-count
(fn (b doc-id) (persist/last-seq b (content/-stream doc-id))))
;; ── replay ──
;; head — materialise the latest document by folding all ops.
(define
content/head
(fn (b doc-id) (doc-apply-all (doc-empty doc-id) (content/ops b doc-id))))
;; at — materialise the document as of sequence `seq` (a version).
(define
content/at
(fn
(b doc-id seq)
(let
((evs (filter (fn (ev) (<= (persist/event-seq ev) seq)) (content/log b doc-id))))
(doc-apply-all
(doc-empty doc-id)
(map (fn (ev) (persist/event-data ev)) evs)))))
;; ── history: per-version metadata, oldest-first ──
(define
content/history
(fn (b doc-id) (map (fn (ev) {:type (persist/event-type ev) :at (persist/event-at ev) :seq (persist/event-seq ev)}) (content/log b doc-id))))
;; ── diff between two materialised document versions ──
;; Returns {:added (ids) :removed (ids) :changed (ids)} where changed = ids
;; present in both whose block content differs.
(define
content/-missing?
(fn (doc id) (= (ct-index-of (doc-blocks doc) id) -1)))
(define
content/-changed
(fn
(old new)
(filter
(fn
(id)
(let
((bo (doc-find old id)) (bn (doc-find new id)))
(cond
((= bo nil) false)
((= bn nil) false)
((= bo bn) false)
(else true))))
(doc-ids old))))
(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (doc-ids old)) :added (filter (fn (id) (content/-missing? old id)) (doc-ids new))}))
;; convenience: diff two persisted versions by seq.
(define
content/diff-versions
(fn
(b doc-id seq-a seq-b)
(content/diff (content/at b doc-id seq-a) (content/at b doc-id seq-b))))

26
lib/content/summary.sx Normal file
View File

@@ -0,0 +1,26 @@
;; content-on-sx — list-card summary projection.
;;
;; content/summary returns a one-call projection for index/listing cards:
;; {:id :title :excerpt :words :reading-minutes :cover}
;; composing the metadata, text, stats and query layers. `cover` is the first
;; image's src (or nil).
;;
;; Requires (loaded by harness): doc.sx, meta.sx (doc-title), text.sx
;; (content/excerpt), stats.sx (word-count/reading), query.sx (select-type).
(define
content/summary-title
(fn (doc) (let ((t (doc-title doc))) (if (= t nil) (doc-id doc) t))))
(define
content/cover
(fn
(doc)
(let
((imgs (content/select-type doc "image")))
(if
(= (len imgs) 0)
nil
(str (blk-get (first imgs) "src"))))))
(define content/summary (fn (doc) {:id (doc-id doc) :reading-minutes (content/reading-minutes doc) :words (content/word-count doc) :title (content/summary-title doc) :excerpt (content/excerpt doc 160) :cover (content/cover doc)}))

74
lib/content/sync.sx Normal file
View File

@@ -0,0 +1,74 @@
;; content-on-sx — external CMS sync via an injected adapter.
;;
;; Sync is a peripheral, not a feature. The core defines a SHAPE — an adapter is
;; a dict {:import (fn external doc-id -> doc) :export (fn doc -> external)} — and
;; delegates to it. The core knows nothing about Ghost's data model; all
;; translation lives in the adapter. Swap the adapter and the core is unchanged;
;; if Ghost goes away, nothing here does.
;;
;; Requires (loaded by harness): block.sx, doc.sx.
;; ── generic boundary: pure delegation ──
(define
content/import
(fn (adapter external doc-id) ((get adapter :import) external doc-id)))
(define content/export (fn (adapter doc) ((get adapter :export) doc)))
;; round-trip a document through an adapter (export then import).
(define
content/round-trip
(fn
(adapter doc)
(content/import adapter (content/export adapter doc) (doc-id doc))))
;; ── a Ghost-flavoured adapter (the peripheral). Ghost knowledge is confined
;; here: a post is {:title :sections (list section)}; a section is a tagged dict
;; {:kind ...} that this adapter maps to/from content blocks. ──
(define
ghost-section->block
(fn
(sec)
(let
((kind (get sec :kind)) (id (get sec :id)))
(cond
((= kind "heading")
(mk-heading id (get sec :level) (get sec :text)))
((= kind "paragraph") (mk-text id (get sec :text)))
((= kind "image") (mk-image id (get sec :src) (get sec :alt)))
((= kind "code") (mk-code id (get sec :language) (get sec :text)))
((= kind "quote") (mk-quote id (get sec :cite) (get sec :text)))
((= kind "hr") (mk-divider id))
((= kind "list") (mk-list id (get sec :ordered) (get sec :items)))
((= kind "embed") (mk-embed id (get sec :url) (get sec :provider)))
(else (mk-text id (get sec :text)))))))
(define
block->ghost-section
(fn
(b)
(let
((t (blk-type b)) (id (blk-id b)))
(cond
((= t "heading") {:id id :text (str (blk-send b "text")) :kind "heading" :level (blk-send b "level")})
((= t "text") {:id id :text (str (blk-send b "text")) :kind "paragraph"})
((= t "image") {:id id :src (str (blk-send b "src")) :alt (str (blk-send b "alt")) :kind "image"})
((= t "code") {:id id :text (str (blk-send b "text")) :kind "code" :language (str (blk-send b "language"))})
((= t "quote") {:cite (str (blk-send b "cite")) :id id :text (str (blk-send b "text")) :kind "quote"})
((= t "divider") {:id id :kind "hr"})
((= t "list") {:items (blk-send b "items") :id id :kind "list" :ordered (blk-send b "ordered")})
((= t "embed") {:id id :provider (str (blk-send b "provider")) :kind "embed" :url (str (blk-send b "url"))})
(else {:id id :text "" :kind "paragraph"})))))
(define
ghost-import
(fn
(post doc-id)
(st-iv-set!
(doc-new doc-id (map ghost-section->block (get post :sections)))
"title"
(get post :title))))
(define ghost-export (fn (doc) {:sections (map block->ghost-section (doc-blocks doc)) :title (st-send doc "title" (list))}))
(define ghost-adapter {:export ghost-export :import ghost-import})

54
lib/content/table.sx Normal file
View File

@@ -0,0 +1,54 @@
;; content-on-sx — table block.
;;
;; CtTable holds `headers` (list of strings) and `rows` (list of string lists).
;; Self-contained: it answers asHTML/asSx/asText/asMarkdown: by folding rows and
;; cells, so it composes with the render boundary with no changes elsewhere. HTML
;; cells are htmlEscaped, SX cells sxEscaped (render.sx must be loaded).
;;
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (escapers);
;; markdown.sx / text.sx for those formats.
(define
content-bootstrap-table!
(fn
()
(begin
(st-class-define! "CtTable" "CtBlock" (list "headers" "rows"))
(ct-def-method! "CtTable" "headers" "headers ^ headers")
(ct-def-method! "CtTable" "rows" "rows ^ rows")
(ct-def-method! "CtTable" "type" "type ^ #table")
(ct-def-method!
"CtTable"
"asHTML"
"asHTML | thead tbody | thead := '<thead><tr>' , (headers inject: '' into: [:a :h | a , '<th>' , h htmlEscaped , '</th>']) , '</tr></thead>'. tbody := '<tbody>' , (rows inject: '' into: [:a :r | a , '<tr>' , (r inject: '' into: [:b :c | b , '<td>' , c htmlEscaped , '</td>']) , '</tr>']) , '</tbody>'. ^ '<table>' , thead , tbody , '</table>'")
(ct-def-method!
"CtTable"
"asSx"
"asSx ^ '(table (thead (tr ' , (headers inject: '' into: [:a :h | a , '(th \"' , h sxEscaped , '\")']) , ')) (tbody ' , (rows inject: '' into: [:a :r | a , '(tr ' , (r inject: '' into: [:b :c | b , '(td \"' , c sxEscaped , '\")']) , ')']) , '))'")
(ct-def-method!
"CtTable"
"asText"
"asText ^ (rows inject: (headers inject: '' into: [:a :h | (a = '' ifTrue: [h] ifFalse: [a , ' ' , h])]) into: [:acc :r | acc , ' ' , (r inject: '' into: [:b :c | (b = '' ifTrue: [c] ifFalse: [b , ' ' , c])])])")
(ct-def-method!
"CtTable"
"asMarkdown:"
"asMarkdown: nl | head sep body | head := '|' , (headers inject: '' into: [:a :h | a , ' ' , h , ' |']). sep := '|' , (headers inject: '' into: [:a :h | a , ' --- |']). body := (rows inject: '' into: [:acc :r | acc , nl , '|' , (r inject: '' into: [:a :c | a , ' ' , c , ' |'])]). ^ head , nl , sep , body")
true)))
(define
mk-table
(fn
(id headers rows)
(st-iv-set!
(st-iv-set!
(st-iv-set! (st-make-instance "CtTable") "id" id)
"headers"
headers)
"rows"
rows)))
(define
table?
(fn (b) (and (st-instance? b) (= (get b :class) "CtTable"))))
(define table-headers (fn (tb) (st-send tb "headers" (list))))
(define table-rows (fn (tb) (st-send tb "rows" (list))))

View File

@@ -0,0 +1,58 @@
;; Extension — anchored-heading HTML render (functional TOC links).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(define
d
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "intro" 1 "Intro"))
(mk-text "p" "Body"))
(mk-section
"s"
(list (mk-heading "sub" 2 "Sub") (mk-text "n" "nested")))))
;; ── headings get id anchors; other blocks unchanged ──
(content-test
"anchored html"
(content/html-anchored d)
"<h1 id=\"intro\">Intro</h1><p>Body</p><section><h2 id=\"sub\">Sub</h2><p>nested</p></section>")
;; ── heading text escaped ──
(content-test
"anchored escapes text"
(content/html-anchored
(doc-append (doc-empty "d") (mk-heading "h" 2 "A < B")))
"<h2 id=\"h\">A &lt; B</h2>")
;; ── non-heading-only doc identical to asHTML ──
(define
np
(doc-append
(doc-append (doc-empty "d") (mk-text "p" "x"))
(mk-image "i" "/a.png" "alt")))
(content-test "no headings == asHTML" (content/html-anchored np) (asHTML np))
;; ── empty doc ──
(content-test "anchored empty" (content/html-anchored (doc-empty "e")) "")
;; ── anchors match TOC ids (end-to-end) ──
(content-test
"anchor ids match toc"
(map (fn (h) (get h :id)) (content/headings d))
(list "intro" "sub"))
;; ── deep nesting ──
(define
deep
(doc-append
(doc-empty "d")
(mk-section
"o"
(list (mk-section "i" (list (mk-heading "deep" 3 "Deep")))))))
(content-test
"deep anchored"
(content/html-anchored deep)
"<section><section><h3 id=\"deep\">Deep</h3></section></section>")

99
lib/content/tests/api.sx Normal file
View File

@@ -0,0 +1,99 @@
;; Phase 1 — public API facade. End-to-end through content/*.
(st-bootstrap-classes!)
(content/bootstrap!)
;; ── build a document via the facade ──
(define d0 (content/empty "post"))
(define
h
(content/block
"heading"
"h"
(list (list "level" 1) (list "text" "Hi"))))
(define p (content/block "text" "p" (list (list "text" "World"))))
(define d1 (content/append (content/append d0 h) p))
(content/op? (content/insert h nil))
(content-test "count" (content/count d1) 2)
(content-test "ids" (content/ids d1) (list "h" "p"))
(content-test "types" (content/types d1) (list "heading" "text"))
(content-test "find" (blk-id (content/find d1 "p")) "p")
(content-test "has? yes" (content/has? d1 "h") true)
(content-test "has? no" (content/has? d1 "x") false)
;; ── content/op? distinguishes a single op from a list / a block ──
(content-test "op? on insert" (content/op? (content/insert h nil)) true)
(content-test
"op? on update"
(content/op? (content/update "p" "text" "z"))
true)
(content-test "op? on list" (content/op? (list (content/delete "h"))) false)
(content-test "op? on block" (content/op? h) false)
(content-test "op? on doc" (content/op? d1) false)
;; ── edit with a single op ──
(define
img
(content/block
"image"
"img"
(list (list "src" "/c.png") (list "alt" "cat"))))
(define d2 (content/edit d1 (content/insert img "h")))
(content-test "edit single op order" (content/ids d2) (list "h" "img" "p"))
(content-test "edit single immutable" (content/ids d1) (list "h" "p"))
(content-test
"edit update"
(str
(blk-send
(content/find
(content/edit d1 (content/update "p" "text" "Edited"))
"p")
"text"))
"Edited")
(content-test
"edit delete"
(content/ids (content/edit d1 (content/delete "h")))
(list "p"))
(content-test
"edit move"
(content/ids (content/edit d1 (content/move "p" 0)))
(list "p" "h"))
;; ── edit with a stream of ops ──
(define ops (list (content/insert img "h") (content/delete "p")))
(content-test
"edit op stream"
(content/ids (content/edit d1 ops))
(list "h" "img"))
(content-test "edit op stream immutable" (content/ids d1) (list "h" "p"))
;; ── render via facade ──
(content-test
"render html"
(content/render d1 "html")
"<h1>Hi</h1><p>World</p>")
(content-test
"render sx"
(content/render d1 "sx")
"(article (h1 \"Hi\")(p \"World\"))")
(content-test
"render html keyword"
(content/render d1 :html)
"<h1>Hi</h1><p>World</p>")
(content-test
"render sx keyword"
(content/render d1 :sx)
"(article (h1 \"Hi\")(p \"World\"))")
(content-test "content/html" (content/html d1) "<h1>Hi</h1><p>World</p>")
(content-test "content/sx" (content/sx d1) "(article (h1 \"Hi\")(p \"World\"))")
;; ── render reflects each version ──
(content-test
"render edited version"
(content/render (content/edit d1 (content/update "h" "text" "Hey")) "html")
"<h1>Hey</h1><p>World</p>")
(content-test
"render original unchanged"
(content/render d1 "html")
"<h1>Hi</h1><p>World</p>")

View File

@@ -0,0 +1,75 @@
;; Phase 1 — typed block objects. Behaviour via message dispatch; fields
;; immutable (copy-on-write).
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
;; ── construction + polymorphic type dispatch ──
(define h (mk-heading "b1" 2 "Title"))
(define t (mk-text "b2" "Body text"))
(define img (mk-image "b3" "/cat.png" "a cat"))
(define code (mk-code "b4" "sx" "(+ 1 2)"))
(define q (mk-quote "b5" "Ada" "to err"))
(define em (mk-embed "b6" "https://v/1" "vimeo"))
(define dv (mk-divider "b7"))
(define ls (mk-list "b8" true (list "one" "two")))
(content-test "heading type" (blk-type h) "heading")
(content-test "text type" (blk-type t) "text")
(content-test "image type" (blk-type img) "image")
(content-test "code type" (blk-type code) "code")
(content-test "quote type" (blk-type q) "quote")
(content-test "embed type" (blk-type em) "embed")
(content-test "divider type" (blk-type dv) "divider")
(content-test "list type" (blk-type ls) "list")
;; ── id via message dispatch ──
(content-test "heading id" (blk-id h) "b1")
(content-test "image id" (blk-id img) "b3")
(content-test "divider id" (blk-id dv) "b7")
;; ── field reads via messages (incl. inherited text) ──
(content-test "heading text inherited" (str (blk-send h "text")) "Title")
(content-test "heading level" (blk-send h "level") 2)
(content-test "text body" (str (blk-send t "text")) "Body text")
(content-test "image src" (str (blk-send img "src")) "/cat.png")
(content-test "image alt" (str (blk-send img "alt")) "a cat")
(content-test "code language" (str (blk-send code "language")) "sx")
(content-test "code text inherited" (str (blk-send code "text")) "(+ 1 2)")
(content-test "quote cite" (str (blk-send q "cite")) "Ada")
(content-test "embed url" (str (blk-send em "url")) "https://v/1")
(content-test "embed provider" (str (blk-send em "provider")) "vimeo")
(content-test "list ordered" (blk-send ls "ordered") true)
(content-test "list items" (blk-send ls "items") (list "one" "two"))
;; ── blk-get reads ivars directly ──
(content-test "blk-get level" (blk-get h "level") 2)
(content-test "blk-get missing nil" (blk-get h "nope") nil)
;; ── copy-on-write: blk-set returns a new block, original untouched ──
(define h2 (blk-set h "level" 1))
(content-test "blk-set new value" (blk-send h2 "level") 1)
(content-test "blk-set original unchanged" (blk-send h "level") 2)
(content-test "blk-set keeps id" (blk-id h2) "b1")
(content-test "blk-set keeps text" (str (blk-send h2 "text")) "Title")
;; ── predicate ──
(content-test "block? on heading" (block? h) true)
(content-test "block? on divider" (block? dv) true)
(content-test "block? on number" (block? 5) false)
(content-test "block? on string" (block? "x") false)
;; ── isBlock message inherited by all ──
(content-test "isBlock heading" (blk-send h "isBlock") true)
(content-test "isBlock list" (blk-send ls "isBlock") true)
;; ── generic mk-block via wire tag ──
(define
g
(mk-block
"heading"
"g1"
(list (list "level" 3) (list "text" "Gen"))))
(content-test "mk-block type" (blk-type g) "heading")
(content-test "mk-block level" (blk-send g "level") 3)
(content-test "mk-block text" (str (blk-send g "text")) "Gen")

View File

@@ -0,0 +1,55 @@
;; Extension — callout / admonition block.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-markdown!)
(content-bootstrap-text!)
(content-bootstrap-callout!)
(define c (mk-callout "c" "warning" "Be careful"))
;; ── identity ──
(content-test "callout is block" (block? c) true)
(content-test "callout? yes" (callout? c) true)
(content-test "callout type" (blk-type c) "callout")
(content-test "callout kind" (callout-kind c) "warning")
;; ── render ──
(content-test
"callout html"
(asHTML c)
"<aside class=\"callout callout-warning\">Be careful</aside>")
(content-test
"callout sx"
(asSx c)
"(aside :class \"callout callout-warning\" \"Be careful\")")
(content-test "callout text" (asText c) "Be careful")
(content-test "callout markdown" (asMarkdown c) "> **warning:** Be careful")
;; ── html escapes text ──
(content-test
"callout html escapes"
(asHTML (mk-callout "c" "note" "a < b"))
"<aside class=\"callout callout-note\">a &lt; b</aside>")
;; ── in a document ──
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "T"))
c))
(content-test
"doc with callout html"
(asHTML d)
"<h1>T</h1><aside class=\"callout callout-warning\">Be careful</aside>")
;; ── validation ──
(content-test
"valid callout"
(content/valid? (doc-append (doc-empty "d") c))
true)
(content-test
"bad callout kind flagged"
(content/issue-kinds
(doc-append (doc-empty "d") (mk-callout "c" 5 "x")))
(list "field"))

View File

@@ -0,0 +1,55 @@
;; Extension — block id remapping / clone.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Title"))
(mk-section "s" (list (mk-text "a" "A") (mk-text "b" "B")))))
;; ── prefix-ids rewrites every id in the tree ──
(define p (content/prefix-ids d "x-"))
(content-test "prefix top-level ids" (doc-ids p) (list "x-h" "x-s"))
(content-test
"prefix tree-ids"
(doc-tree-ids p)
(list "x-h" "x-s" "x-a" "x-b"))
(content-test "prefix immutable" (doc-tree-ids d) (list "h" "s" "a" "b"))
(content-test "prefix preserves content" (asHTML p) (asHTML d))
(content-test
"prefix preserves nested content"
(str (blk-send (doc-deep-find p "x-a") "text"))
"A")
;; ── custom remap fn ──
(define u (content/remap-ids d (fn (id) (str id "!"))))
(content-test "remap suffix" (doc-tree-ids u) (list "h!" "s!" "a!" "b!"))
;; ── collision-free composition ──
(define
d2
(doc-append (doc-empty "d2") (mk-heading "h" 2 "Other")))
(define
combined
(content/concat
(content/prefix-ids d "left-")
(content/prefix-ids d2 "right-")))
(content-test
"combined ids unique"
(doc-tree-ids combined)
(list "left-h" "left-s" "left-a" "left-b" "right-h"))
(content-test "combined validates" (content/valid? combined) true)
;; without prefixing, the shared id "h" collides
(content-test
"unprefixed collides"
(content/valid? (content/concat d d2))
false)
;; ── render of combined ──
(content-test
"combined render"
(asHTML combined)
"<h1>Title</h1><section><p>A</p><p>B</p></section><h2>Other</h2>")

View File

@@ -0,0 +1,76 @@
;; Extension — document composition.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(define
a
(doc-with-title
(doc-append (doc-empty "a") (mk-heading "h" 1 "A"))
"Doc A"))
(define
b
(doc-append
(doc-append (doc-empty "b") (mk-text "p" "B1"))
(mk-text "q" "B2")))
;; ── concat ──
(define ab (content/concat a b))
(content-test "concat ids" (doc-ids ab) (list "h" "p" "q"))
(content-test "concat keeps first id" (doc-id ab) "a")
(content-test "concat keeps first title" (doc-title ab) "Doc A")
(content-test "concat immutable a" (doc-ids a) (list "h"))
(content-test "concat immutable b" (doc-ids b) (list "p" "q"))
;; ── prepend ──
(define ba (content/prepend a b))
(content-test "prepend ids" (doc-ids ba) (list "p" "q" "h"))
(content-test "prepend keeps a id" (doc-id ba) "a")
;; ── concat with empty ──
(content-test
"concat empty right"
(doc-ids (content/concat a (doc-empty "e")))
(list "h"))
(content-test
"concat empty left"
(doc-ids (content/concat (doc-empty "e") b))
(list "p" "q"))
;; ── concat-all ──
(define c (doc-append (doc-empty "c") (mk-divider "d")))
(content-test
"concat-all order"
(doc-ids (content/concat-all (list a b c)))
(list "h" "p" "q" "d"))
(content-test
"concat-all keeps first id"
(doc-id (content/concat-all (list a b c)))
"a")
(content-test
"concat-all single"
(doc-ids (content/concat-all (list a)))
(list "h"))
(content-test
"concat-all empty"
(doc-ids (content/concat-all (list)))
(list))
;; ── render of composed doc ──
(content-test
"composed renders"
(asHTML (content/concat a b))
"<h1>A</h1><p>B1</p><p>B2</p>")
;; ── wrap-section collapses blocks into a subtree ──
(define w (content/wrap-section ab "sec"))
(content-test "wrap top-level is one section" (doc-ids w) (list "sec"))
(content-test
"wrap children preserved"
(doc-tree-ids w)
(list "sec" "h" "p" "q"))
(content-test
"wrap renders nested"
(asHTML w)
"<section><h1>A</h1><p>B1</p><p>B2</p></section>")

View File

@@ -0,0 +1,136 @@
;; Hardening — non-core block types (callout/table/media/section) survive the
;; flat and tree CvRDT materialise paths (regression for the ct-class-for-type
;; fix: these route through crdt-element->block -> mk-block).
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-render!)
(content-bootstrap-section!)
(content-bootstrap-callout!)
(content-bootstrap-table!)
(content-bootstrap-media!)
;; ── flat CRDT: callout / table / media leaves ──
(define
s
(crdt-apply-all
(crdt-empty)
(list
(crdt-op-insert
"co"
"callout"
(crdt-pos 1 0)
(list (list "kind" "note") (list "text" "hi"))
1
0)
(crdt-op-insert
"tb"
"table"
(crdt-pos 2 0)
(list (list "headers" (list "A")) (list "rows" (list (list "1"))))
1
0)
(crdt-op-insert
"vid"
"media"
(crdt-pos 3 0)
(list (list "kind" "video") (list "src" "/v.mp4"))
1
0))))
(content-test
"flat crdt callout render"
(asHTML (crdt-materialize "d" s))
"<aside class=\"callout callout-note\">hi</aside><table><thead><tr><th>A</th></tr></thead><tbody><tr><td>1</td></tr></tbody></table><video src=\"/v.mp4\" controls></video>")
(content-test "flat crdt order" (crdt-order s) (list "co" "tb" "vid"))
;; ── flat CRDT: callout field via LWW update ──
(define s2 (crdt-update s "co" "text" "edited" 5 1))
(content-test
"flat crdt callout update"
(str (blk-send (doc-find (crdt-materialize "d" s2) "co") "text"))
"edited")
;; ── tree CRDT: callout/table inside a section ──
(define
t
(crdt-tree-apply-all
(crdt-empty)
(list
(crdt-tree-op-insert
"sec"
"section"
(crdt-pos 1 0)
""
(list)
1
0)
(crdt-tree-op-insert
"co"
"callout"
(crdt-pos 1 0)
"sec"
(list (list "kind" "tip") (list "text" "T"))
1
0)
(crdt-tree-op-insert
"tb"
"table"
(crdt-pos 2 0)
"sec"
(list (list "headers" (list "H")) (list "rows" (list)))
1
0))))
(content-test
"tree crdt nested blocks"
(doc-tree-ids (crdt-tree-materialize "d" t))
(list "sec" "co" "tb"))
(content-test
"tree crdt nested render"
(asHTML (crdt-tree-materialize "d" t))
"<section><aside class=\"callout callout-tip\">T</aside><table><thead><tr><th>H</th></tr></thead><tbody></tbody></table></section>")
;; ── tree CRDT: concurrent callout inserts into a section converge ──
(define
base
(crdt-tree-insert
(crdt-empty)
"sec"
"section"
(crdt-pos 1 0)
""
(list)
1
0))
(define
rA
(crdt-tree-insert
base
"x"
"callout"
(crdt-pos 5 1)
"sec"
(list (list "kind" "note") (list "text" "A"))
2
1))
(define
rB
(crdt-tree-insert
base
"y"
"media"
(crdt-pos 5 2)
"sec"
(list (list "kind" "audio") (list "src" "/a.mp3"))
2
2))
(content-test
"tree crdt mixed converge"
(=
(get (crdt-tree-merge rA rB) :elements)
(get (crdt-tree-merge rB rA) :elements))
true)
(content-test
"tree crdt mixed ids"
(doc-tree-ids (crdt-tree-materialize "d" (crdt-tree-merge rA rB)))
(list "sec" "x" "y"))

View File

@@ -0,0 +1,139 @@
;; Extension — durable collaborative replication (CRDT ops on persist).
;; Replicas log independently; converge merges the logs deterministically.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-render!)
(define same? (fn (a b) (= (get a :elements) (get b :elements))))
(define B (persist/open))
;; replica "a" (origin): inserts h, p
(crdt/commit!
B
"doc"
"a"
(crdt-op-insert
"h"
"heading"
(crdt-pos 1 0)
(list (list "level" 1) (list "text" "T"))
1
1)
1)
(crdt/commit!
B
"doc"
"a"
(crdt-op-insert
"p"
"text"
(crdt-pos 2 0)
(list (list "text" "Body"))
1
1)
1)
;; replica "b" (concurrent): edits p, inserts x
(crdt/commit-all!
B
"doc"
"b"
(list
(crdt-op-update "p" "text" "Edited" 5 2)
(crdt-op-insert
"x"
"text"
(crdt-pos 3 0)
(list (list "text" "X"))
6
2))
5)
;; ── durability ──
(content-test
"replica a version"
(crdt/replica-version B "doc" "a")
2)
(content-test
"replica b version"
(crdt/replica-version B "doc" "b")
2)
(content-test
"replica a ops len"
(len (crdt/replica-ops B "doc" "a"))
2)
;; ── single-replica replay ──
(content-test
"replay a order"
(crdt-order (crdt/replay B "doc" "a"))
(list "h" "p"))
(content-test
"replay a == apply-all"
(same?
(crdt/replay B "doc" "a")
(crdt-apply-all (crdt-empty) (crdt/replica-ops B "doc" "a")))
true)
;; ── converge ──
(content-test
"converge order"
(crdt/order B "doc" (list "a" "b"))
(list "h" "p" "x"))
(content-test
"converge replica-order-independent"
(same?
(crdt/converge B "doc" (list "a" "b"))
(crdt/converge B "doc" (list "b" "a")))
true)
(content-test
"converge LWW p edited"
(str
(blk-send (doc-find (crdt/document B "doc" (list "a" "b")) "p") "text"))
"Edited")
(content-test
"converged document render"
(asHTML (crdt/document B "doc" (list "a" "b")))
"<h1>T</h1><p>Edited</p><p>X</p>")
;; ── duplicate delivery is idempotent ──
(crdt/commit!
B
"doc"
"a"
(crdt-op-insert
"p"
"text"
(crdt-pos 2 0)
(list (list "text" "Body"))
1
1)
1)
(content-test
"duplicate op no effect on converge"
(crdt/order B "doc" (list "a" "b"))
(list "h" "p" "x"))
(content-test
"duplicate keeps LWW value"
(str
(blk-send (doc-find (crdt/document B "doc" (list "a" "b")) "p") "text"))
"Edited")
;; ── new op on a replica is reflected after re-converge ──
(crdt/commit! B "doc" "b" (crdt-op-delete "h") 9)
(content-test
"delete reflected after reconverge"
(crdt/order B "doc" (list "a" "b"))
(list "p" "x"))
;; ── isolation: unknown doc converges to empty ──
(content-test
"unknown doc empty"
(crdt/order B "other" (list "a" "b"))
(list))
(content-test
"unknown replica empty ops"
(len (crdt/replica-ops B "doc" "zzz"))
0)

View File

@@ -0,0 +1,253 @@
;; Extension — nested-tree CvRDT. Sections nest and merge collaboratively;
;; convergence is order/replica/duplicate-insensitive like the flat layer.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-render!)
(content-bootstrap-section!)
(define same? (fn (a b) (= (get a :elements) (get b :elements))))
;; base: a section "s" at root, with one child heading.
(define
base
(crdt-tree-insert
(crdt-tree-insert
(crdt-empty)
"s"
"section"
(crdt-pos 1 0)
""
(list)
1
0)
"h"
"heading"
(crdt-pos 1 0)
"s"
(list (list "level" 2) (list "text" "Sub"))
1
0))
;; ── materialise rebuilds the tree ──
(content-test "tree order root" (crdt-tree-order base) (list "s"))
(content-test
"tree materialize ids"
(doc-tree-ids (crdt-tree-materialize "d" base))
(list "s" "h"))
(content-test
"tree render"
(asHTML (crdt-tree-materialize "d" base))
"<section><h2>Sub</h2></section>")
;; ── concurrent inserts into the SAME section converge + order by pos ──
(define
rA
(crdt-tree-insert
base
"a"
"text"
(crdt-pos 5 1)
"s"
(list (list "text" "A"))
2
1))
(define
rB
(crdt-tree-insert
base
"b"
"text"
(crdt-pos 5 2)
"s"
(list (list "text" "B"))
2
2))
(content-test
"same-parent merge commutes"
(same? (crdt-tree-merge rA rB) (crdt-tree-merge rB rA))
true)
(content-test
"same-parent order deterministic"
(doc-tree-ids (crdt-tree-materialize "d" (crdt-tree-merge rA rB)))
(list "s" "h" "a" "b"))
;; ── concurrent inserts into DIFFERENT parents converge ──
(define
base2
(crdt-tree-insert
(crdt-tree-insert
(crdt-empty)
"s1"
"section"
(crdt-pos 1 0)
""
(list)
1
0)
"s2"
"section"
(crdt-pos 2 0)
""
(list)
1
0))
(define
x
(crdt-tree-insert
base2
"x"
"text"
(crdt-pos 1 0)
"s1"
(list (list "text" "X"))
2
1))
(define
y
(crdt-tree-insert
base2
"y"
"text"
(crdt-pos 1 0)
"s2"
(list (list "text" "Y"))
2
2))
(define m (crdt-tree-merge x y))
(content-test
"different-parent commutes"
(same? m (crdt-tree-merge y x))
true)
(content-test
"different-parent tree"
(doc-tree-ids (crdt-tree-materialize "d" m))
(list "s1" "x" "s2" "y"))
(content-test
"different-parent render"
(asHTML (crdt-tree-materialize "d" m))
"<section><p>X</p></section><section><p>Y</p></section>")
;; ── nested sections (section inside section) ──
(define
nested
(crdt-tree-apply-all
(crdt-empty)
(list
(crdt-tree-op-insert
"outer"
"section"
(crdt-pos 1 0)
""
(list)
1
0)
(crdt-tree-op-insert
"inner"
"section"
(crdt-pos 1 0)
"outer"
(list)
1
0)
(crdt-tree-op-insert
"leaf"
"text"
(crdt-pos 1 0)
"inner"
(list (list "text" "deep"))
1
0))))
(content-test
"nested tree ids"
(doc-tree-ids (crdt-tree-materialize "d" nested))
(list "outer" "inner" "leaf"))
(content-test
"nested render"
(asHTML (crdt-tree-materialize "d" nested))
"<section><section><p>deep</p></section></section>")
;; ── ops in any order converge (commutative) ──
(define
opA
(crdt-tree-op-insert
"p"
"text"
(crdt-pos 6 0)
"s"
(list (list "text" "P"))
3
1))
(define opB (crdt-tree-op-update "h" "text" "Edited" 5 1))
(define opC (crdt-tree-op-delete "h"))
(content-test
"ops commute"
(same?
(crdt-tree-apply-all base (list opA opB opC))
(crdt-tree-apply-all base (list opC opB opA)))
true)
(content-test
"ops idempotent"
(same?
(crdt-tree-apply-all base (list opA opB))
(crdt-tree-apply-all
(crdt-tree-apply-all base (list opA opB))
(list opA opB)))
true)
;; ── update into a section + LWW ──
(define u1 (crdt-tree-update base "h" "text" "v5" 5 1))
(define u2 (crdt-tree-update base "h" "text" "v7" 7 2))
(content-test
"tree LWW higher ts"
(str
(blk-send
(doc-deep-find (crdt-tree-materialize "d" (crdt-tree-merge u1 u2)) "h")
"text"))
"v7")
;; ── delete inside a section ──
(content-test
"delete in section"
(doc-tree-ids (crdt-tree-materialize "d" (crdt-tree-delete base "h")))
(list "s"))
;; ── merge idempotence ──
(content-test "merge idempotent self" (same? (crdt-tree-merge m m) m) true)
;; ── full convergence: two replicas, divergent edits in different sections ──
(define
repl1
(crdt-tree-apply-all
base2
(list
(crdt-tree-op-insert
"p1"
"text"
(crdt-pos 1 0)
"s1"
(list (list "text" "from1"))
5
1))))
(define
repl2
(crdt-tree-apply-all
base2
(list
(crdt-tree-op-insert
"p2"
"text"
(crdt-pos 1 0)
"s2"
(list (list "text" "from2"))
6
2))))
(content-test
"two-replica tree converges"
(same? (crdt-tree-merge repl1 repl2) (crdt-tree-merge repl2 repl1))
true)
(content-test
"two-replica tree ids"
(doc-tree-ids (crdt-tree-materialize "d" (crdt-tree-merge repl1 repl2)))
(list "s1" "p1" "s2" "p2"))

315
lib/content/tests/crdt.sx Normal file
View File

@@ -0,0 +1,315 @@
;; Phase 3 — collaborative merge (CvRDT). The merge is a join: commutative,
;; associative, idempotent. Tests apply ops in any order, twice, and merge
;; replicas both ways — all must converge to identical state.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-render!)
(define same? (fn (a b) (= (get a :elements) (get b :elements))))
;; ── position order (Logoot) ──
(content-test
"pos lt"
(crdt-pos-compare
(crdt-pos 1 0)
(crdt-pos 2 0))
-1)
(content-test
"pos gt"
(crdt-pos-compare
(crdt-pos 2 0)
(crdt-pos 1 0))
1)
(content-test
"pos eq"
(crdt-pos-compare
(crdt-pos 1 0)
(crdt-pos 1 0))
0)
(content-test
"pos actor tiebreak"
(crdt-pos-compare
(crdt-pos 1 1)
(crdt-pos 1 2))
-1)
(content-test
"between > left"
(<
(crdt-pos-compare
(crdt-pos 1 0)
(crdt-pos-between
(crdt-pos 1 0)
(crdt-pos 2 0)
9))
0)
true)
(content-test
"between < right"
(<
(crdt-pos-compare
(crdt-pos-between
(crdt-pos 1 0)
(crdt-pos 2 0)
9)
(crdt-pos 2 0))
0)
true)
(content-test
"between start < right"
(<
(crdt-pos-compare
(crdt-pos-between nil (crdt-pos 5 0) 9)
(crdt-pos 5 0))
0)
true)
(content-test
"between end > left"
(<
(crdt-pos-compare
(crdt-pos 5 0)
(crdt-pos-between (crdt-pos 5 0) nil 9))
0)
true)
;; ── build + materialise ──
(define
base
(crdt-insert
(crdt-insert
(crdt-empty)
"h"
"heading"
(crdt-pos 1 0)
(list (list "level" 1) (list "text" "Title"))
1
0)
"p"
"text"
(crdt-pos 2 0)
(list (list "text" "Body"))
1
0))
(content-test "order" (crdt-order base) (list "h" "p"))
(content-test
"materialize ids"
(doc-ids (crdt-materialize "d" base))
(list "h" "p"))
(content-test
"materialize render"
(asHTML (crdt-materialize "d" base))
"<h1>Title</h1><p>Body</p>")
;; ── commutativity: ops in any order converge ──
(define
opA
(crdt-op-insert
"x"
"text"
(crdt-pos 3 0)
(list (list "text" "X"))
2
1))
(define opB (crdt-op-update "p" "text" "Edited" 5 1))
(define opC (crdt-op-delete "h"))
(define s-abc (crdt-apply-all base (list opA opB opC)))
(define s-cba (crdt-apply-all base (list opC opB opA)))
(define s-bca (crdt-apply-all base (list opB opC opA)))
(content-test "commutative abc=cba" (same? s-abc s-cba) true)
(content-test "commutative abc=bca" (same? s-abc s-bca) true)
(content-test "commutative result order" (crdt-order s-abc) (list "p" "x"))
;; ── idempotence: applying ops twice changes nothing ──
(content-test
"idempotent ops"
(same? s-abc (crdt-apply-all s-abc (list opA opB opC)))
true)
;; ── update-before-insert is not lost ──
(define
ub
(crdt-apply-all
(crdt-empty)
(list
(crdt-op-update "z" "text" "late" 3 1)
(crdt-op-insert
"z"
"text"
(crdt-pos 1 0)
(list (list "text" "orig"))
1
1))))
(content-test
"update before insert kept"
(str (blk-send (doc-find (crdt-materialize "d" ub) "z") "text"))
"late")
;; ── delete-before-insert: remove-wins ──
(define
db
(crdt-apply-all
(crdt-empty)
(list
(crdt-op-delete "k")
(crdt-op-insert
"k"
"text"
(crdt-pos 1 0)
(list (list "text" "x"))
1
1))))
(content-test "delete before insert removes" (crdt-order db) (list))
;; ── concurrent inserts converge + deterministic order ──
(define
rA
(crdt-insert
base
"a1"
"text"
(crdt-pos 5 1)
(list (list "text" "A"))
2
1))
(define
rB
(crdt-insert
base
"b1"
"text"
(crdt-pos 5 2)
(list (list "text" "B"))
2
2))
(content-test
"merge commutes"
(same? (crdt-merge rA rB) (crdt-merge rB rA))
true)
(content-test
"merge order deterministic AB"
(crdt-order (crdt-merge rA rB))
(list "h" "p" "a1" "b1"))
(content-test
"merge order deterministic BA"
(crdt-order (crdt-merge rB rA))
(list "h" "p" "a1" "b1"))
;; ── merge idempotence ──
(define mAB (crdt-merge rA rB))
(content-test "merge idempotent self" (same? (crdt-merge mAB mAB) mAB) true)
(content-test
"merge idempotent remerge"
(same? (crdt-merge mAB rA) mAB)
true)
;; ── concurrent same-field update: LWW by (ts, actor) ──
(define u1 (crdt-update base "p" "text" "v-ts5" 5 1))
(define u2 (crdt-update base "p" "text" "v-ts7" 7 2))
(content-test
"LWW higher ts wins"
(str
(blk-send
(doc-find (crdt-materialize "d" (crdt-merge u1 u2)) "p")
"text"))
"v-ts7")
(content-test
"LWW commutes"
(same? (crdt-merge u1 u2) (crdt-merge u2 u1))
true)
(define t1 (crdt-update base "p" "text" "actor1" 9 1))
(define t2 (crdt-update base "p" "text" "actor2" 9 2))
(content-test
"LWW tie -> actor wins"
(str
(blk-send
(doc-find (crdt-materialize "d" (crdt-merge t1 t2)) "p")
"text"))
"actor2")
;; ── concurrent disjoint-field updates both survive ──
(define f1 (crdt-update base "h" "text" "NewTitle" 5 1))
(define f2 (crdt-update base "h" "level" 3 5 2))
(define fm (crdt-merge f1 f2))
(content-test
"disjoint field text"
(str (blk-send (doc-find (crdt-materialize "d" fm) "h") "text"))
"NewTitle")
(content-test
"disjoint field level"
(blk-send (doc-find (crdt-materialize "d" fm) "h") "level")
3)
(content-test "disjoint commutes" (same? fm (crdt-merge f2 f1)) true)
;; ── associativity ──
(define c1 (crdt-update base "p" "text" "c1" 4 1))
(define
c2
(crdt-insert
base
"n2"
"text"
(crdt-pos 6 0)
(list (list "text" "N"))
2
2))
(define c3 (crdt-delete base "h"))
(content-test
"associative"
(same?
(crdt-merge (crdt-merge c1 c2) c3)
(crdt-merge c1 (crdt-merge c2 c3)))
true)
(content-test
"merge-all = fold"
(same?
(crdt-merge-all (list c1 c2 c3))
(crdt-merge c1 (crdt-merge c2 c3)))
true)
;; ── full convergence: two replicas, divergent edits, merge both ways ──
(define
repl-1
(crdt-apply-all
base
(list
(crdt-op-update "p" "text" "from-1" 5 1)
(crdt-op-insert
"img"
"image"
(crdt-pos-between
(crdt-pos 1 0)
(crdt-pos 2 0)
1)
(list (list "src" "/a.png") (list "alt" "a"))
6
1))))
(define
repl-2
(crdt-apply-all
base
(list
(crdt-op-delete "h")
(crdt-op-update "p" "text" "from-2" 7 2))))
(content-test
"two-replica converges"
(same? (crdt-merge repl-1 repl-2) (crdt-merge repl-2 repl-1))
true)
(content-test
"two-replica result order"
(crdt-order (crdt-merge repl-1 repl-2))
(list "img" "p"))
(content-test
"two-replica LWW field"
(str
(blk-send
(doc-find (crdt-materialize "d" (crdt-merge repl-1 repl-2)) "p")
"text"))
"from-2")
(content-test
"two-replica idempotent"
(same?
(crdt-merge (crdt-merge repl-1 repl-2) repl-1)
(crdt-merge repl-1 repl-2))
true)

116
lib/content/tests/data.sx Normal file
View File

@@ -0,0 +1,116 @@
;; Extension — portable data serialization (to-data / from-data round-trip).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-text!)
(content-bootstrap-markdown!)
(content-bootstrap-section!)
(content-bootstrap-table!)
(content-bootstrap-callout!)
(content-bootstrap-media!)
;; ── block->data shape ──
(define h (mk-heading "h" 2 "Hi"))
(content-test "block->data id" (get (block->data h) :id) "h")
(content-test "block->data type" (get (block->data h) :type) "heading")
(content-test "block->data fields" (get (block->data h) :fields) {:text "Hi" :level 2})
;; ── round-trip a mixed document with metadata ──
(define
d
(doc-with-meta
(doc-append
(doc-append
(doc-append
(doc-append (doc-empty "post") (mk-heading "h" 1 "Title"))
(mk-text "p" "Body"))
(mk-image "img" "/c.png" "cat"))
(mk-list "l" true (list "a" "b")))
{:slug "s" :title "T" :tags (list "x" "y")}))
(define rt (content/from-data (content/to-data d)))
(content-test "rt id" (doc-id rt) "post")
(content-test "rt title" (doc-title rt) "T")
(content-test "rt slug" (doc-slug rt) "s")
(content-test "rt tags" (doc-tags rt) (list "x" "y"))
(content-test "rt ids" (doc-ids rt) (list "h" "p" "img" "l"))
(content-test "rt render" (asHTML rt) (asHTML d))
(content-test
"rt heading level"
(blk-send (doc-find rt "h") "level")
1)
(content-test
"rt list items"
(blk-send (doc-find rt "l") "items")
(list "a" "b"))
;; ── nested sections round-trip ──
(define
ds
(doc-append
(doc-empty "d")
(mk-section
"s"
(list
(mk-heading "nh" 2 "N")
(mk-section "i" (list (mk-text "x" "deep")))))))
(define rts (content/from-data (content/to-data ds)))
(content-test "rt nested render" (asHTML rts) (asHTML ds))
(content-test "rt nested tree-ids" (doc-tree-ids rts) (doc-tree-ids ds))
(content-test
"rt nested deep-find"
(str (blk-send (doc-deep-find rts "x") "text"))
"deep")
;; ── table round-trip ──
(define
dtb
(doc-append
(doc-empty "d")
(mk-table "t" (list "A" "B") (list (list "1" "2")))))
(define rtt (content/from-data (content/to-data dtb)))
(content-test "rt table render" (asHTML rtt) (asHTML dtb))
(content-test
"rt table headers"
(table-headers (doc-find rtt "t"))
(list "A" "B"))
;; ── callout + media round-trip (regression: ct-class-for-type must know them) ──
(define
dcm
(doc-append
(doc-append (doc-empty "d") (mk-callout "co" "warning" "careful"))
(mk-video "vid" "/clip.mp4")))
(define rtcm (content/from-data (content/to-data dcm)))
(content-test "rt callout+media render" (asHTML rtcm) (asHTML dcm))
(content-test
"rt callout kind"
(str (blk-send (doc-find rtcm "co") "kind"))
"warning")
(content-test
"rt media kind"
(str (blk-send (doc-find rtcm "vid") "kind"))
"video")
(content-test
"rt callout+media types"
(doc-types rtcm)
(list "callout" "media"))
;; ── data is plain (no st-instance markers at top level) ──
(define dat (content/to-data d))
(content-test "data id field" (get dat :id) "post")
(content-test "data block count" (len (get dat :blocks)) 4)
(content-test
"data first block type"
(get (first (get dat :blocks)) :type)
"heading")
;; ── empty doc round-trip ──
(content-test
"rt empty ids"
(doc-ids (content/from-data (content/to-data (doc-empty "e"))))
(list))
(content-test
"rt no-meta title nil"
(doc-title (content/from-data (content/to-data (doc-empty "e"))))
nil)

132
lib/content/tests/doc.sx Normal file
View File

@@ -0,0 +1,132 @@
;; Phase 1 — ordered block document: apply edit ops, structural moves.
;; Every op returns a NEW document; the input is never mutated.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(define h (mk-heading "h" 1 "Title"))
(define p1 (mk-text "p1" "First"))
(define p2 (mk-text "p2" "Second"))
(define img (mk-image "img" "/c.png" "cat"))
;; ── empty + construction ──
(define d0 (doc-empty "doc1"))
(content-test "empty id" (doc-id d0) "doc1")
(content-test "empty type" (doc-type d0) "document")
(content-test "empty count" (doc-count d0) 0)
(content-test "doc? on doc" (doc? d0) true)
(content-test "doc? on block" (doc? h) false)
;; ── append + order ──
(define d1 (doc-append (doc-append (doc-append d0 h) p1) p2))
(content-test "append count" (doc-count d1) 3)
(content-test "append order" (doc-ids d1) (list "h" "p1" "p2"))
(content-test "append types" (doc-types d1) (list "heading" "text" "text"))
(content-test "block-at 0" (blk-id (doc-block-at d1 0)) "h")
;; ── append is immutable ──
(content-test "append leaves original" (doc-count d0) 0)
;; ── find / index / has ──
(content-test "find p1" (blk-id (doc-find d1 "p1")) "p1")
(content-test "find missing" (doc-find d1 "nope") nil)
(content-test "index-of p2" (doc-index-of d1 "p2") 2)
(content-test "index-of missing" (doc-index-of d1 "nope") -1)
(content-test "has? yes" (doc-has? d1 "h") true)
(content-test "has? no" (doc-has? d1 "x") false)
;; ── insert-after ──
(define d2 (doc-insert-after d1 img "h"))
(content-test "insert-after order" (doc-ids d2) (list "h" "img" "p1" "p2"))
(content-test
"insert-after prepend"
(doc-ids (doc-insert-after d1 img nil))
(list "img" "h" "p1" "p2"))
(content-test
"insert-after missing appends"
(doc-ids (doc-insert-after d1 img "zzz"))
(list "h" "p1" "p2" "img"))
(content-test "insert-after immutable" (doc-ids d1) (list "h" "p1" "p2"))
;; ── insert-at ──
(content-test
"insert-at 0"
(doc-ids (doc-insert-at d1 img 0))
(list "img" "h" "p1" "p2"))
(content-test
"insert-at 1"
(doc-ids (doc-insert-at d1 img 1))
(list "h" "img" "p1" "p2"))
;; ── update (copy-on-write block) ──
(define d3 (doc-update d1 "p1" "text" "Edited"))
(content-test
"update value"
(str (blk-send (doc-find d3 "p1") "text"))
"Edited")
(content-test "update keeps order" (doc-ids d3) (list "h" "p1" "p2"))
(content-test
"update immutable"
(str (blk-send (doc-find d1 "p1") "text"))
"First")
;; ── delete ──
(define d4 (doc-delete d1 "p1"))
(content-test "delete order" (doc-ids d4) (list "h" "p2"))
(content-test "delete count" (doc-count d4) 2)
(content-test "delete immutable" (doc-count d1) 3)
(content-test
"delete missing no-op"
(doc-ids (doc-delete d1 "x"))
(list "h" "p1" "p2"))
;; ── move ──
(content-test
"move p2 to front"
(doc-ids (doc-move d1 "p2" 0))
(list "p2" "h" "p1"))
(content-test
"move h to end"
(doc-ids (doc-move d1 "h" 2))
(list "p1" "p2" "h"))
(content-test
"move missing no-op"
(doc-ids (doc-move d1 "x" 0))
(list "h" "p1" "p2"))
(content-test "move immutable" (doc-ids d1) (list "h" "p1" "p2"))
;; ── op constructors + interpreter ──
(content-test
"op-insert apply"
(doc-ids (doc-apply d1 (op-insert img "h")))
(list "h" "img" "p1" "p2"))
(content-test
"op-delete apply"
(doc-ids (doc-apply d1 (op-delete "h")))
(list "p1" "p2"))
(content-test
"op-move apply"
(doc-ids (doc-apply d1 (op-move "p2" 0)))
(list "p2" "h" "p1"))
(content-test
"op-update apply"
(str
(blk-send
(doc-find (doc-apply d1 (op-update "p1" "text" "X")) "p1")
"text"))
"X")
;; ── apply-all: a stream of ops ──
(define
ops
(list (op-insert img "h") (op-delete "p1") (op-move "p2" 0)))
(content-test
"apply-all"
(doc-ids (doc-apply-all d1 ops))
(list "p2" "h" "img"))
(content-test "apply-all immutable" (doc-ids d1) (list "h" "p1" "p2"))
(content-test
"apply-all empty"
(doc-ids (doc-apply-all d1 (list)))
(list "h" "p1" "p2"))

148
lib/content/tests/fed.sx Normal file
View File

@@ -0,0 +1,148 @@
;; Phase 4 — federated documents: trust-gated peer ops + concurrent-external-
;; edit conflict resolution via the CRDT.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-render!)
(define same? (fn (a b) (= (get a :elements) (get b :elements))))
;; base shared document, then a local edit
(define
base
(crdt-insert
(crdt-insert
(crdt-empty)
"h"
"heading"
(crdt-pos 1 0)
(list (list "level" 1) (list "text" "T"))
1
0)
"p"
"text"
(crdt-pos 2 0)
(list (list "text" "Body"))
1
0))
(define local (crdt-update base "p" "text" "local" 5 1))
;; ── provenance ──
(content-test
"authored tags author"
(get (content/authored (crdt-op-delete "h") "ed") :author)
"ed")
(content-test
"signed tags sig"
(get (content/signed (crdt-op-delete "h") "ed" "sig1") :sig)
"sig1")
(content-test "trusted? yes" (content/trusted? (list "ed" "al") "ed") true)
(content-test "trusted? no" (content/trusted? (list "ed") "mal") false)
;; peer ops: ed is trusted, mal is not
(define
peer-ops
(list
(content/authored
(crdt-op-update "p" "text" "peer-ed" 7 2)
"ed")
(content/authored
(crdt-op-insert
"x"
"text"
(crdt-pos 3 0)
(list (list "text" "X"))
8
2)
"ed")
(content/authored (crdt-op-delete "h") "mal")))
(define res (content/merge-peer local (list "ed") peer-ops))
;; ── trust gate: only ed's ops applied ──
(content-test "accepted count" (len (content/accepted res)) 2)
(content-test "rejected count" (len (content/rejected res)) 1)
(content-test
"rejected is mal's"
(get (first (content/rejected res)) :author)
"mal")
;; ── resulting document ──
(define rdoc (crdt-materialize "d" (content/peer-state res)))
(content-test "untrusted delete blocked: h survives" (doc-has? rdoc "h") true)
(content-test "trusted insert applied: x present" (doc-has? rdoc "x") true)
(content-test "result order" (doc-ids rdoc) (list "h" "p" "x"))
(content-test
"trusted edit wins (ts7 > ts5)"
(str (blk-send (doc-find rdoc "p") "text"))
"peer-ed")
;; ── order-independence of accepted peer ops ──
(define res-rev (content/merge-peer local (list "ed") (reverse peer-ops)))
(content-test
"peer merge order-independent"
(same? (content/peer-state res) (content/peer-state res-rev))
true)
;; ── trust = nobody → nothing applied, state unchanged ──
(define res0 (content/merge-peer local (list) peer-ops))
(content-test
"no trust accepts none"
(len (content/accepted res0))
0)
(content-test
"no trust rejects all"
(len (content/rejected res0))
3)
(content-test
"no trust state unchanged"
(same? (content/peer-state res0) local)
true)
;; ── pluggable predicate gate (acl-on-sx hook) ──
(define
res-pred
(content/merge-peer-with
local
(fn (op) (= (get op :author) "ed"))
peer-ops))
(content-test
"predicate gate == list gate"
(same? (content/peer-state res-pred) (content/peer-state res))
true)
;; ── conflict on concurrent external edit: local vs external, same field ──
;; external (peer) state edits p concurrently with a later ts; CRDT reconciles.
(define
external
(crdt-update base "p" "text" "external" 9 2))
(content-test
"conflict LWW deterministic"
(str
(blk-send
(doc-find (crdt-materialize "d" (crdt-merge local external)) "p")
"text"))
"external")
(content-test
"conflict merge commutes"
(same? (crdt-merge local external) (crdt-merge external local))
true)
(content-test
"conflict merge idempotent"
(same?
(crdt-merge (crdt-merge local external) external)
(crdt-merge local external))
true)
;; concurrent external edit with LOWER ts loses to local
(define
external-old
(crdt-update base "p" "text" "stale" 3 2))
(content-test
"older external loses to local"
(str
(blk-send
(doc-find (crdt-materialize "d" (crdt-merge local external-old)) "p")
"text"))
"local")

View File

@@ -0,0 +1,83 @@
;; Extension — global find/replace across text-bearing blocks.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(define
d
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Foo title"))
(mk-text "p" "the Foo is here"))
(mk-section
"s"
(list (mk-text "n" "nested Foo") (mk-image "img" "/foo.png" "Foo alt")))))
(define r (content/find-replace d "Foo" "Bar"))
;; ── replaces in heading + text ──
(content-test
"replace heading"
(str (blk-send (doc-deep-find r "h") "text"))
"Bar title")
(content-test
"replace text"
(str (blk-send (doc-deep-find r "p") "text"))
"the Bar is here")
(content-test
"replace nested text"
(str (blk-send (doc-deep-find r "n") "text"))
"nested Bar")
;; ── does NOT touch image alt/src (not a text field) ──
(content-test
"image alt untouched"
(str (blk-send (doc-deep-find r "img") "alt"))
"Foo alt")
(content-test
"image src untouched"
(str (blk-send (doc-deep-find r "img") "src"))
"/foo.png")
;; ── immutable ──
(content-test
"original unchanged"
(str (blk-send (doc-deep-find d "p") "text"))
"the Foo is here")
;; ── multiple occurrences in one block ──
(content-test
"all occurrences"
(str
(blk-send
(doc-find
(content/find-replace
(doc-append (doc-empty "d") (mk-text "p" "a a a"))
"a"
"b")
"p")
"text"))
"b b b")
;; ── code + quote text replaced ──
(define
d2
(doc-append
(doc-append (doc-empty "d") (mk-code "c" "sx" "(old)"))
(mk-quote "q" "src" "old saying")))
(define r2 (content/find-replace d2 "old" "new"))
(content-test
"replace code"
(str (blk-send (doc-find r2 "c") "text"))
"(new)")
(content-test
"replace quote"
(str (blk-send (doc-find r2 "q") "text"))
"new saying")
;; ── no match → unchanged render ──
(content-test
"no match"
(asHTML (content/find-replace d "zzz" "qqq"))
(asHTML d))

View File

@@ -0,0 +1,72 @@
;; Extension — document flatten (un-nest sections).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Top"))
(mk-section "s" (list (mk-text "a" "A") (mk-text "b" "B")))))
;; ── one level un-nested ──
(define f (content/flatten d))
(content-test "flatten ids" (doc-ids f) (list "h" "a" "b"))
(content-test
"flatten no sections"
(content/types f)
(list "heading" "text" "text"))
(content-test "flatten immutable" (doc-ids d) (list "h" "s"))
(content-test "flatten render" (asHTML f) "<h1>Top</h1><p>A</p><p>B</p>")
;; ── deep nesting fully flattened ──
(define
deep
(doc-append
(doc-empty "d")
(mk-section
"o"
(list
(mk-text "x" "X")
(mk-section
"i"
(list (mk-text "y" "Y") (mk-heading "z" 2 "Z")))))))
(content-test
"deep flatten ids"
(doc-ids (content/flatten deep))
(list "x" "y" "z"))
;; ── inverse of wrap-section ──
(define
plain
(doc-append
(doc-append (doc-empty "p") (mk-text "a" "A"))
(mk-text "b" "B")))
(content-test
"flatten . wrap == identity ids"
(doc-ids (content/flatten (content/wrap-section plain "sec")))
(doc-ids plain))
(content-test
"flatten . wrap == identity render"
(asHTML (content/flatten (content/wrap-section plain "sec")))
(asHTML plain))
;; ── already-flat doc unchanged ──
(content-test
"flat unchanged"
(asHTML (content/flatten plain))
(asHTML plain))
;; ── empty section disappears ──
(content-test
"empty section flattens away"
(doc-ids
(content/flatten (doc-append (doc-empty "d") (mk-section "s" (list)))))
(list))
;; ── empty doc ──
(content-test
"flatten empty"
(doc-ids (content/flatten (doc-empty "e")))
(list))

View File

@@ -0,0 +1,61 @@
;; Extension — multi-document index + tag filtering.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-text!)
(define
a
(doc-with-meta
(doc-append (doc-empty "a") (mk-text "p" "first post"))
{:title "A" :tags (list "sx" "news")}))
(define
b
(doc-with-meta
(doc-append (doc-empty "b") (mk-text "p" "second post"))
{:title "B" :tags (list "news")}))
(define
c
(doc-with-meta
(doc-append (doc-empty "c") (mk-text "p" "third"))
{:title "C" :tags (list "sx")}))
(define docs (list a b c))
;; ── index = list of summaries ──
(define idx (content/index docs))
(content-test "index count" (len idx) 3)
(content-test
"index titles"
(map (fn (s) (get s :title)) idx)
(list "A" "B" "C"))
(content-test
"index ids"
(map (fn (s) (get s :id)) idx)
(list "a" "b" "c"))
(content-test "index excerpt" (get (first idx) :excerpt) "first post")
;; ── has-tag? ──
(content-test "has-tag yes" (content/has-tag? a "news") true)
(content-test "has-tag no" (content/has-tag? c "news") false)
;; ── index-by-tag (category page) ──
(content-test
"by-tag news"
(map (fn (s) (get s :id)) (content/index-by-tag docs "news"))
(list "a" "b"))
(content-test
"by-tag sx"
(map (fn (s) (get s :id)) (content/index-by-tag docs "sx"))
(list "a" "c"))
(content-test "by-tag none" (content/index-by-tag docs "missing") (list))
;; ── all-tags (tag cloud, deduped, document order) ──
(content-test "all-tags" (content/all-tags docs) (list "sx" "news"))
(content-test "all-tags empty" (content/all-tags (list)) (list))
(content-test
"all-tags untagged"
(content/all-tags (list (doc-empty "x")))
(list))
;; ── empty index ──
(content-test "empty index" (content/index (list)) (list))

View File

@@ -0,0 +1,79 @@
;; Extension — Markdown render mode. asMarkdown is a polymorphic message send;
;; the boundary supplies the newline.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-markdown!)
(define nl (str "\n"))
;; ── per-block ──
(content-test
"heading h3"
(asMarkdown (mk-heading "h" 3 "Title"))
"### Title")
(content-test
"heading h1"
(asMarkdown (mk-heading "h" 1 "T"))
"# T")
(content-test "text md" (asMarkdown (mk-text "p" "body")) "body")
(content-test
"quote md"
(asMarkdown (mk-quote "q" "Ada" "to err"))
"> to err")
(content-test
"image md"
(asMarkdown (mk-image "i" "/c.png" "cat"))
"![cat](/c.png)")
(content-test
"embed md"
(asMarkdown (mk-embed "e" "https://v/1" "vimeo"))
"[embed](https://v/1)")
(content-test "divider md" (asMarkdown (mk-divider "d")) "---")
(content-test
"code md"
(asMarkdown (mk-code "c" "sx" "(+ 1 2)"))
(str "```sx" nl "(+ 1 2)" nl "```"))
(content-test
"ul md"
(asMarkdown (mk-list "u" false (list "a" "b" "c")))
(str "- a" nl "- b" nl "- c"))
(content-test
"ol md"
(asMarkdown (mk-list "o" true (list "x" "y")))
(str "1. x" nl "1. y"))
(content-test "empty list md" (asMarkdown (mk-list "e" false (list))) "")
;; ── document joins blocks with a blank line ──
(define
d
(doc-append
(doc-append
(doc-append (doc-empty "doc") (mk-heading "h" 2 "Title"))
(mk-text "p" "Hello"))
(mk-divider "d")))
(content-test
"doc md"
(asMarkdown d)
(str "## Title" nl nl "Hello" nl nl "---"))
(content-test "empty doc md" (asMarkdown (doc-empty "e")) "")
;; ── via facade ──
(content-test "render md" (content/render d "md") (asMarkdown d))
(content-test "render markdown" (content/render d "markdown") (asMarkdown d))
(content-test "render md keyword" (content/render d :md) (asMarkdown d))
(content-test "content/markdown alias" (content/markdown d) (asMarkdown d))
(content-test
"block-markdown alias"
(block-markdown (mk-heading "h" 2 "X"))
"## X")
;; ── reflects edits / immutability ──
(content-test
"md after update"
(asMarkdown (doc-update d "p" "text" "Edited"))
(str "## Title" nl nl "Edited" nl nl "---"))
(content-test
"md original unchanged"
(asMarkdown d)
(str "## Title" nl nl "Hello" nl nl "---"))

View File

@@ -0,0 +1,71 @@
;; Extension — Markdown document export (frontmatter + body), round-trips with
;; md/import including metadata.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-markdown!)
(content-bootstrap-table!)
(define nl (str "\n"))
;; ── no metadata → plain markdown (no frontmatter) ──
(define plain (doc-append (doc-empty "d") (mk-heading "h" 1 "Hi")))
(content-test
"no-meta == asMarkdown"
(content/markdown-doc plain)
(asMarkdown plain))
(content-test "no-meta no frontmatter" (content/markdown-doc plain) "# Hi")
;; ── full metadata frontmatter ──
(define
d
(doc-with-meta
(doc-append (doc-empty "post") (mk-heading "h" 1 "Hi"))
{:slug "my-post" :title "My Post" :tags (list "a" "b")}))
(content-test
"frontmatter export"
(content/markdown-doc d)
(str
"---"
nl
"title: My Post"
nl
"slug: my-post"
nl
"tags: a, b"
nl
"---"
nl
nl
"# Hi"))
;; ── title only ──
(content-test
"title-only frontmatter"
(content/markdown-doc
(doc-with-title (doc-append (doc-empty "p") (mk-text "x" "body")) "T"))
(str "---" nl "title: T" nl "---" nl nl "body"))
;; ── round-trip: import . export keeps metadata + blocks ──
(define rt (md/import (content/markdown-doc d) "post"))
(content-test "round-trip title" (doc-title rt) "My Post")
(content-test "round-trip slug" (doc-slug rt) "my-post")
(content-test "round-trip tags" (doc-tags rt) (list "a" "b"))
(content-test "round-trip body" (doc-types rt) (list "heading"))
(content-test
"round-trip body text"
(str (blk-send (doc-find rt "b0") "text"))
"Hi")
;; ── round-trip a richer doc ──
(define
d2
(doc-with-meta
(doc-append
(doc-append (doc-empty "p") (mk-heading "h" 2 "Title"))
(mk-text "p" "para text"))
{:title "Big" :tags (list "x")}))
(define rt2 (md/import (content/markdown-doc d2) "p"))
(content-test "rt2 title" (doc-title rt2) "Big")
(content-test "rt2 tags" (doc-tags rt2) (list "x"))
(content-test "rt2 types" (doc-types rt2) (list "heading" "text"))

View File

@@ -0,0 +1,206 @@
;; Extension — Markdown import adapter (markdown text -> blocks), inverse of
;; asMarkdown. Round-trips canonical Markdown; parses frontmatter + tables.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-markdown!)
(content-bootstrap-table!)
(define nl (str "\n"))
;; ── headings ──
(define dh (md/import "# Title" "d"))
(content-test "heading import type" (doc-types dh) (list "heading"))
(content-test
"heading level"
(blk-send (doc-find dh "b0") "level")
1)
(content-test
"heading text"
(str (blk-send (doc-find dh "b0") "text"))
"Title")
(content-test
"h3 import"
(blk-send (doc-find (md/import "### Deep" "d") "b0") "level")
3)
;; ── paragraph (consecutive lines join with space) ──
(content-test
"paragraph join"
(str
(blk-send
(doc-find (md/import (str "hello" nl "world") "d") "b0")
"text"))
"hello world")
;; ── blockquote, divider ──
(content-test
"blockquote"
(str (blk-send (doc-find (md/import "> quoted" "d") "b0") "text"))
"quoted")
(content-test "divider" (doc-types (md/import "---" "d")) (list "divider"))
;; ── unordered + ordered lists ──
(define dul (md/import (str "- a" nl "- b" nl "- c") "d"))
(content-test "ul type" (doc-types dul) (list "list"))
(content-test
"ul not ordered"
(blk-send (doc-find dul "b0") "ordered")
false)
(content-test
"ul items"
(blk-send (doc-find dul "b0") "items")
(list "a" "b" "c"))
(define dol (md/import (str "1. x" nl "2. y") "d"))
(content-test "ol ordered" (blk-send (doc-find dol "b0") "ordered") true)
(content-test
"ol items"
(blk-send (doc-find dol "b0") "items")
(list "x" "y"))
;; ── fenced code ──
(define dc (md/import (str "```sx" nl "(+ 1 2)" nl "(* 3 4)" nl "```") "d"))
(content-test "code type" (doc-types dc) (list "code"))
(content-test
"code language"
(str (blk-send (doc-find dc "b0") "language"))
"sx")
(content-test
"code body"
(str (blk-send (doc-find dc "b0") "text"))
(str "(+ 1 2)" nl "(* 3 4)"))
;; ── multiple blocks separated by blank lines ──
(define dm (md/import (str "# H" nl nl "para" nl nl "- a" nl "- b") "d"))
(content-test "multi types" (doc-types dm) (list "heading" "text" "list"))
(content-test "multi ids" (doc-ids dm) (list "b0" "b1" "b2"))
;; ── empty / blank input ──
(content-test "empty input" (doc-ids (md/import "" "d")) (list))
(content-test
"blank lines only"
(doc-ids (md/import (str nl nl) "d"))
(list))
;; ── pipe tables ──
(define
dt
(md/import
(str
"| Name | Age |"
nl
"| --- | --- |"
nl
"| Ada | 36 |"
nl
"| Al | 40 |")
"d"))
(content-test "table import type" (doc-types dt) (list "table"))
(content-test
"table headers"
(table-headers (doc-find dt "b0"))
(list "Name" "Age"))
(content-test
"table rows"
(table-rows (doc-find dt "b0"))
(list (list "Ada" "36") (list "Al" "40")))
(content-test
"table round-trip"
(asMarkdown
(md/import (str "| A | B |" nl "| --- | --- |" nl "| 1 | 2 |") "d"))
(str "| A | B |" nl "| --- | --- |" nl "| 1 | 2 |"))
(define
dmix
(md/import
(str
"# Title"
nl
nl
"| H1 | H2 |"
nl
"| --- | --- |"
nl
"| a | b |"
nl
nl
"para")
"d"))
(content-test
"table mixed types"
(doc-types dmix)
(list "heading" "table" "text"))
;; ── frontmatter ──
(define
dfm
(md/import
(str
"---"
nl
"title: My Post"
nl
"slug: my-post"
nl
"tags: a, b, c"
nl
"---"
nl
"# Hi"
nl
nl
"body")
"d"))
(content-test "fm title" (doc-title dfm) "My Post")
(content-test "fm slug" (doc-slug dfm) "my-post")
(content-test "fm tags" (doc-tags dfm) (list "a" "b" "c"))
(content-test "fm body types" (doc-types dfm) (list "heading" "text"))
(content-test
"fm body content"
(str (blk-send (doc-find dfm "b0") "text"))
"Hi")
(content-test "no fm title nil" (doc-title (md/import "# Hi" "d")) nil)
(content-test
"hr not frontmatter"
(doc-types (md/import (str "text" nl nl "---") "d"))
(list "text" "divider"))
(define dfmo (md/import (str "---" nl "title: T" nl "---") "d"))
(content-test "fm only title" (doc-title dfmo) "T")
(content-test "fm only empty body" (doc-ids dfmo) (list))
;; ── round-trip: import . export == identity (canonical markdown) ──
(define
src
(str
"# Title"
nl
nl
"hello world"
nl
nl
"> quoted"
nl
nl
"- a"
nl
"- b"
nl
nl
"---"))
(content-test "round-trip markdown" (asMarkdown (md/import src "d")) src)
(content-test
"round-trip code"
(asMarkdown (md/import (str "```js" nl "x = 1" nl "```") "d"))
(str "```js" nl "x = 1" nl "```"))
;; ── adapter form ──
(content-test
"adapter import"
(doc-types (content/import markdown-adapter "# Hi" "d"))
(list "heading"))
(content-test
"adapter export round-trip"
(content/export markdown-adapter (content/import markdown-adapter src "d"))
src)
;; ── imported doc validates ──
(content-test "imported doc valid" (content/valid? (md/import src "d")) true)

View File

@@ -0,0 +1,59 @@
;; Extension — video/audio media block.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-markdown!)
(content-bootstrap-text!)
(content-bootstrap-media!)
(define v (mk-video "v" "/clip.mp4"))
(define a (mk-audio "a" "/song.mp3"))
;; ── identity ──
(content-test "media is block" (block? v) true)
(content-test "media? yes" (media? v) true)
(content-test "video type" (blk-type v) "media")
(content-test "video kind" (media-kind v) "video")
(content-test "audio kind" (media-kind a) "audio")
;; ── render ──
(content-test
"video html"
(asHTML v)
"<video src=\"/clip.mp4\" controls></video>")
(content-test
"audio html"
(asHTML a)
"<audio src=\"/song.mp3\" controls></audio>")
(content-test "video sx" (asSx v) "(video :src \"/clip.mp4\")")
(content-test "video text" (asText v) "")
(content-test "video markdown" (asMarkdown v) "[video](/clip.mp4)")
(content-test "audio markdown" (asMarkdown a) "[audio](/song.mp3)")
;; ── html escapes src ──
(content-test
"media html escapes"
(asHTML (mk-video "v" "/a.mp4?x=1&y=2"))
"<video src=\"/a.mp4?x=1&amp;y=2\" controls></video>")
;; ── in a document ──
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Watch"))
v))
(content-test
"doc with media html"
(asHTML d)
"<h1>Watch</h1><video src=\"/clip.mp4\" controls></video>")
;; ── validation ──
(content-test
"valid media"
(content/valid? (doc-append (doc-empty "d") v))
true)
(content-test
"bad media kind flagged"
(content/issue-kinds
(doc-append (doc-empty "d") (mk-media "m" "movie" "/x")))
(list "field"))

79
lib/content/tests/meta.sx Normal file
View File

@@ -0,0 +1,79 @@
;; Extension — document metadata (title/slug/tags) + Ghost title plumbing.
(st-bootstrap-classes!)
(content/bootstrap!)
(define d (doc-empty "post"))
;; ── defaults ──
(content-test "default title nil" (doc-title d) nil)
(content-test "default slug nil" (doc-slug d) nil)
(content-test "default tags empty" (doc-tags d) (list))
;; ── copy-on-write setters ──
(define d2 (doc-with-title d "Hello World"))
(content-test "with-title" (doc-title d2) "Hello World")
(content-test "with-title immutable" (doc-title d) nil)
(content-test "with-title keeps id" (doc-id d2) "post")
(define d3 (doc-with-slug (doc-with-title d "T") "my-slug"))
(content-test "with-slug" (doc-slug d3) "my-slug")
(content-test "title preserved with slug" (doc-title d3) "T")
(define d4 (doc-with-tags d (list "a" "b")))
(content-test "with-tags" (doc-tags d4) (list "a" "b"))
(content-test "add-tag" (doc-tags (doc-add-tag d4 "c")) (list "a" "b" "c"))
(content-test
"add-tag from empty"
(doc-tags (doc-add-tag d "x"))
(list "x"))
;; ── batch + dict ──
(define d5 (doc-with-meta d {:slug "s" :title "T" :tags (list "t1")}))
(content-test "with-meta title" (doc-title d5) "T")
(content-test "with-meta slug" (doc-slug d5) "s")
(content-test "with-meta tags" (doc-tags d5) (list "t1"))
(content-test
"with-meta partial leaves title"
(doc-title (doc-with-meta d {:slug "only"}))
nil)
(content-test "doc-meta dict" (doc-meta d5) {:slug "s" :id "post" :title "T" :tags (list "t1")})
;; ── constructor with metadata ──
(define d6 (doc-new-meta "p2" (list (mk-text "x" "hi")) {:title "Post 2"}))
(content-test "new-meta title" (doc-title d6) "Post 2")
(content-test "new-meta blocks" (doc-ids d6) (list "x"))
;; ── facade aliases ──
(content-test "content/title" (content/title d5) "T")
(content-test
"content/with-title"
(content/title (content/with-title d "Z"))
"Z")
(content-test "content/meta" (content/meta d5) (doc-meta d5))
;; ── metadata coexists with block ops ──
(define
d7
(doc-append
(doc-with-title (doc-empty "x") "Titled")
(mk-text "p" "body")))
(content-test "meta + blocks coexist" (doc-ids d7) (list "p"))
(content-test "meta survives append" (doc-title d7) "Titled")
(content-test
"meta survives edit"
(doc-title (doc-update d7 "p" "text" "changed"))
"Titled")
;; ── Ghost adapter now carries title ──
(define post {:sections (list {:id "h" :text "Hi" :kind "heading" :level 1}) :title "My Post"})
(define gd (content/import ghost-adapter post "post"))
(content-test "ghost import title" (doc-title gd) "My Post")
(content-test
"ghost export title"
(get (content/export ghost-adapter gd) :title)
"My Post")
(content-test
"ghost title round-trip"
(doc-title (content/round-trip ghost-adapter gd))
"My Post")

63
lib/content/tests/move.sx Normal file
View File

@@ -0,0 +1,63 @@
;; Extension — relative block reorder.
(st-bootstrap-classes!)
(content/bootstrap!)
(define
d
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-text "a" "A"))
(mk-text "b" "B"))
(mk-text "c" "C")))
;; ── move-before ──
(content-test
"move-before"
(doc-ids (content/move-before d "c" "a"))
(list "c" "a" "b"))
(content-test
"move-before mid"
(doc-ids (content/move-before d "c" "b"))
(list "a" "c" "b"))
(content-test "move-before immutable" (doc-ids d) (list "a" "b" "c"))
;; ── move-after ──
(content-test
"move-after"
(doc-ids (content/move-after d "a" "b"))
(list "b" "a" "c"))
(content-test
"move-after last"
(doc-ids (content/move-after d "a" "c"))
(list "b" "c" "a"))
;; ── move-to-front / back ──
(content-test
"move-to-front"
(doc-ids (content/move-to-front d "c"))
(list "c" "a" "b"))
(content-test
"move-to-back"
(doc-ids (content/move-to-back d "a"))
(list "b" "c" "a"))
(content-test
"front already first"
(doc-ids (content/move-to-front d "a"))
(list "a" "b" "c"))
;; ── no-ops ──
(content-test
"missing id no-op"
(doc-ids (content/move-before d "zzz" "a"))
(list "a" "b" "c"))
(content-test
"missing target no-op"
(doc-ids (content/move-before d "a" "zzz"))
(list "a" "b" "c"))
;; ── render after move ──
(content-test
"render after move"
(asHTML (content/move-after d "a" "c"))
"<p>B</p><p>C</p><p>A</p>")

View File

@@ -0,0 +1,99 @@
;; Extension — document normalization (drop empty text blocks + empty sections).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
;; ── drop empty text blocks ──
(define
d
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Hi"))
(mk-text "empty" ""))
(mk-text "p" "Body")))
(content-test
"drops empty text"
(doc-ids (content/normalize d))
(list "h" "p"))
(content-test "normalize immutable" (doc-ids d) (list "h" "empty" "p"))
(content-test
"keeps non-empty text"
(str (blk-send (doc-find (content/normalize d) "p") "text"))
"Body")
;; ── drop empty sections ──
(define
d2
(doc-append
(doc-append (doc-empty "d") (mk-text "p" "x"))
(mk-section "empty-sec" (list))))
(content-test
"drops empty section"
(doc-ids (content/normalize d2))
(list "p"))
;; ── section that becomes empty (all children dropped) is itself dropped ──
(define
d3
(doc-append
(doc-empty "d")
(mk-section "s" (list (mk-text "e1" "") (mk-text "e2" "")))))
(content-test
"section emptied then dropped"
(doc-ids (content/normalize d3))
(list))
;; ── section with some content keeps surviving children ──
(define
d4
(doc-append
(doc-empty "d")
(mk-section
"s"
(list (mk-text "e" "") (mk-heading "k" 2 "Keep")))))
(define n4 (content/normalize d4))
(content-test "section kept" (doc-ids n4) (list "s"))
(content-test
"empty child dropped, real kept"
(doc-tree-ids n4)
(list "s" "k"))
;; ── nested: empty deep section removed, content bubbles correctly ──
(define
d5
(doc-append
(doc-empty "d")
(mk-section
"outer"
(list (mk-text "a" "A") (mk-section "inner" (list (mk-text "x" "")))))))
(content-test
"nested empty inner dropped"
(doc-tree-ids (content/normalize d5))
(list "outer" "a"))
;; ── already-clean doc unchanged ──
(define
clean
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "T"))
(mk-text "p" "B")))
(content-test
"clean doc unchanged ids"
(doc-ids (content/normalize clean))
(list "h" "p"))
(content-test
"clean doc render"
(asHTML (content/normalize clean))
(asHTML clean))
;; ── non-text empties preserved (divider, image with empty alt) ──
(define
d6
(doc-append
(doc-append (doc-empty "d") (mk-divider "dv"))
(mk-image "i" "/a.png" "")))
(content-test
"divider + image kept"
(doc-ids (content/normalize d6))
(list "dv" "i"))

View File

@@ -0,0 +1,78 @@
;; Extension — nested document outline.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
;; H1 / H2 H2 / H1 -> [h1{children: h2,h3}, h4]
(define
d
(doc-append
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "a" 1 "A"))
(mk-heading "b" 2 "B"))
(mk-heading "c" 2 "C"))
(mk-heading "e" 1 "E")))
(define o (content/outline d))
(content-test "outline top count" (len o) 2)
(content-test "outline first id" (get (first o) :id) "a")
(content-test
"outline first children ids"
(map (fn (n) (get n :id)) (get (first o) :children))
(list "b" "c"))
(content-test "outline second top" (get (nth o 1) :id) "e")
(content-test
"outline second no children"
(get (nth o 1) :children)
(list))
;; ── deeper nesting: H1 / H2 / H3 ──
(define
d2
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "x" 1 "X"))
(mk-heading "y" 2 "Y"))
(mk-heading "z" 3 "Z")))
(define o2 (content/outline d2))
(content-test "deep top" (get (first o2) :id) "x")
(content-test
"deep child"
(get (first (get (first o2) :children)) :id)
"y")
(content-test
"deep grandchild"
(get (first (get (first (get (first o2) :children)) :children)) :id)
"z")
;; ── node carries text + level ──
(content-test "node text" (get (first o) :text) "A")
(content-test "node level" (get (first o) :level) 1)
;; ── empty / no headings ──
(content-test "outline empty" (content/outline (doc-empty "e")) (list))
(content-test
"outline no headings"
(content/outline (doc-append (doc-empty "d") (mk-text "p" "x")))
(list))
;; ── starting at H2 (no H1) still forms a forest ──
(define
d3
(doc-append
(doc-append (doc-empty "d") (mk-heading "p" 2 "P"))
(mk-heading "q" 2 "Q")))
(content-test "no-h1 forest count" (len (content/outline d3)) 2)
;; ── headings nested inside sections are found (tree-wide via query) ──
(define
d4
(doc-append
(doc-append (doc-empty "d") (mk-heading "top" 1 "Top"))
(mk-section "s" (list (mk-heading "in" 2 "In")))))
(content-test
"section heading nested in outline"
(map (fn (n) (get n :id)) (get (first (content/outline d4)) :children))
(list "in"))

View File

@@ -0,0 +1,39 @@
;; Extension — SEO-complete HTML page (lang + meta description).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-text!)
(define
d
(doc-with-title
(doc-append
(doc-append (doc-empty "post") (mk-heading "h" 1 "Hi"))
(mk-text "p" "Hello world"))
"My Title"))
(content-test
"page-full"
(content/page-full d)
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>My Title</title><meta name=\"description\" content=\"Hi Hello world\"></head><body><h1>Hi</h1><p>Hello world</p></body></html>")
;; description escaped
(content-test
"page-full escapes description"
(content/page-full
(doc-with-title
(doc-append (doc-empty "x") (mk-text "p" "a < b & c"))
"T"))
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>T</title><meta name=\"description\" content=\"a &lt; b &amp; c\"></head><body><p>a &lt; b &amp; c</p></body></html>")
;; title falls back to id, empty description for empty doc
(content-test
"page-full empty"
(content/page-full (doc-empty "fallback"))
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>fallback</title><meta name=\"description\" content=\"\"></head><body></body></html>")
;; body reflects edits
(content-test
"page-full reflects edits"
(content/page-full (doc-update d "p" "text" "Bye now"))
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>My Title</title><meta name=\"description\" content=\"Hi Bye now\"></head><body><h1>Hi</h1><p>Bye now</p></body></html>")

42
lib/content/tests/page.sx Normal file
View File

@@ -0,0 +1,42 @@
;; Extension — full HTML page wrapper.
(st-bootstrap-classes!)
(content/bootstrap!)
(define
d
(doc-with-title
(doc-append (doc-empty "post") (mk-heading "h" 1 "Hi"))
"My Title"))
(content-test
"page"
(content/page d)
"<!doctype html><html><head><meta charset=\"utf-8\"><title>My Title</title></head><body><h1>Hi</h1></body></html>")
(content-test
"page title escaped"
(content/page (doc-with-title (doc-empty "x") "A < B"))
"<!doctype html><html><head><meta charset=\"utf-8\"><title>A &lt; B</title></head><body></body></html>")
(content-test
"page falls back to id"
(content/page (doc-empty "fallback"))
"<!doctype html><html><head><meta charset=\"utf-8\"><title>fallback</title></head><body></body></html>")
(content-test "page-title from meta" (content/page-title d) "My Title")
(content-test
"page-title fallback id"
(content/page-title (doc-empty "z"))
"z")
(content-test
"page body reflects edits"
(content/page (doc-update d "h" "text" "Bye"))
"<!doctype html><html><head><meta charset=\"utf-8\"><title>My Title</title></head><body><h1>Bye</h1></body></html>")
(content-test
"page multi-block body"
(content/page
(doc-append (doc-with-title (doc-empty "p") "T") (mk-text "x" "para")))
"<!doctype html><html><head><meta charset=\"utf-8\"><title>T</title></head><body><p>para</p></body></html>")

View File

@@ -0,0 +1,89 @@
;; Extension — block query + table of contents.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(define
d
(doc-append
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "h1" 1 "Intro"))
(mk-text "p1" "para"))
(mk-image "img" "/a.png" "alt"))
(mk-section
"s"
(list
(mk-heading "h2" 2 "Sub")
(mk-text "p2" "more")
(mk-image "img2" "/b.png" "b")))))
;; ── select-type (tree-wide) ──
(content-test
"select headings ids"
(map (fn (b) (blk-id b)) (content/select-type d "heading"))
(list "h1" "h2"))
(content-test
"select images ids"
(map (fn (b) (blk-id b)) (content/select-type d "image"))
(list "img" "img2"))
(content-test
"select text ids"
(map (fn (b) (blk-id b)) (content/select-type d "text"))
(list "p1" "p2"))
(content-test
"select section ids"
(map (fn (b) (blk-id b)) (content/select-type d "section"))
(list "s"))
;; ── count-type ──
(content-test "count headings" (content/count-type d "heading") 2)
(content-test "count images" (content/count-type d "image") 2)
(content-test "count dividers" (content/count-type d "divider") 0)
;; ── select with custom predicate ──
(content-test
"select-ids custom"
(content/select-ids d (fn (b) (= (blk-type b) "image")))
(list "img" "img2"))
(content-test
"select custom field"
(map
(fn (b) (blk-id b))
(content/select
d
(fn
(b)
(if
(= (blk-type b) "heading")
(= (blk-get b "level") 2)
false))))
(list "h2"))
;; ── headings / TOC ──
(content-test
"headings TOC"
(content/headings d)
(list {:id "h1" :text "Intro" :level 1} {:id "h2" :text "Sub" :level 2}))
(content-test
"empty doc no headings"
(content/headings (doc-empty "e"))
(list))
;; ── deeply nested ──
(define
deep
(doc-append
(doc-empty "d")
(mk-section
"o"
(list (mk-section "i" (list (mk-heading "deep" 3 "Deep")))))))
(content-test
"deep heading found"
(map (fn (b) (blk-id b)) (content/select-type deep "heading"))
(list "deep"))
(content-test
"deep toc level"
(get (first (content/headings deep)) :level)
3)

135
lib/content/tests/render.sx Normal file
View File

@@ -0,0 +1,135 @@
;; Phase 1 — render boundary. asHTML / asSx are polymorphic message sends on
;; blocks and the document. Escaping happens at the boundary.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-render!)
(define h (mk-heading "h" 2 "Title"))
(define p (mk-text "p" "Hello"))
(define code (mk-code "c" "sx" "(+ 1 2)"))
(define q (mk-quote "q" "Ada" "to err"))
(define img (mk-image "i" "/c.png" "cat"))
(define em (mk-embed "e" "https://v/1" "vimeo"))
(define dv (mk-divider "d"))
(define ul (mk-list "u" false (list "a" "b")))
(define ol (mk-list "o" true (list "x" "y")))
;; ── per-block asHTML ──
(content-test "heading html" (asHTML h) "<h2>Title</h2>")
(content-test "text html" (asHTML p) "<p>Hello</p>")
(content-test
"code html"
(asHTML code)
"<pre><code class=\"language-sx\">(+ 1 2)</code></pre>")
(content-test "quote html" (asHTML q) "<blockquote>to err</blockquote>")
(content-test "image html" (asHTML img) "<img src=\"/c.png\" alt=\"cat\">")
(content-test "embed html" (asHTML em) "<iframe src=\"https://v/1\"></iframe>")
(content-test "divider html" (asHTML dv) "<hr>")
(content-test "ul html" (asHTML ul) "<ul><li>a</li><li>b</li></ul>")
(content-test "ol html" (asHTML ol) "<ol><li>x</li><li>y</li></ol>")
;; ── per-block asSx ──
(content-test "heading sx" (asSx h) "(h2 \"Title\")")
(content-test "text sx" (asSx p) "(p \"Hello\")")
(content-test "code sx" (asSx code) "(pre (code \"(+ 1 2)\"))")
(content-test "quote sx" (asSx q) "(blockquote \"to err\")")
(content-test "image sx" (asSx img) "(img :src \"/c.png\" :alt \"cat\")")
(content-test "embed sx" (asSx em) "(iframe :src \"https://v/1\")")
(content-test "divider sx" (asSx dv) "(hr)")
(content-test "ul sx" (asSx ul) "(ul (li \"a\")(li \"b\"))")
(content-test "ol sx" (asSx ol) "(ol (li \"x\")(li \"y\"))")
;; ── document folds children (pure message dispatch) ──
(define d (doc-append (doc-append (doc-append (doc-empty "doc") h) p) dv))
(content-test "doc html" (asHTML d) "<h2>Title</h2><p>Hello</p><hr>")
(content-test "doc sx" (asSx d) "(article (h2 \"Title\")(p \"Hello\")(hr))")
(content-test "empty doc html" (asHTML (doc-empty "e")) "")
(content-test "empty doc sx" (asSx (doc-empty "e")) "(article )")
;; ── render-* / block-* aliases ──
(content-test "render-html alias" (render-html d) (asHTML d))
(content-test "render-sx alias" (render-sx d) (asSx d))
(content-test "block-html alias" (block-html h) "<h2>Title</h2>")
;; ── render reflects edits (immutability: each render is of a version) ──
(define d2 (doc-update d "p" "text" "Edited"))
(content-test
"render after update"
(asHTML d2)
"<h2>Title</h2><p>Edited</p><hr>")
(content-test
"original render unchanged"
(asHTML d)
"<h2>Title</h2><p>Hello</p><hr>")
(content-test
"render after move"
(asHTML (doc-move d "h" 2))
"<p>Hello</p><hr><h2>Title</h2>")
(content-test
"render after delete"
(asHTML (doc-delete d "p"))
"<h2>Title</h2><hr>")
;; ── HTML escaping at the boundary ──
(define xh (mk-heading "xh" 2 "A < B & \"C\""))
(define xp (mk-text "xp" "<script>alert(1)</script>"))
(define xi (mk-image "xi" "/a.png?x=1&y=2" "tag <b>"))
(define xl (mk-list "xl" false (list "a<1" "b&2")))
(content-test
"escape heading text"
(asHTML xh)
"<h2>A &lt; B &amp; &quot;C&quot;</h2>")
(content-test
"escape paragraph"
(asHTML xp)
"<p>&lt;script&gt;alert(1)&lt;/script&gt;</p>")
(content-test
"escape image attrs"
(asHTML xi)
"<img src=\"/a.png?x=1&amp;y=2\" alt=\"tag &lt;b&gt;\">")
(content-test
"escape list items"
(asHTML xl)
"<ul><li>a&lt;1</li><li>b&amp;2</li></ul>")
(content-test
"escape ampersand once"
(asHTML (mk-text "amp" "a & b"))
"<p>a &amp; b</p>")
(content-test
"escape in document"
(asHTML (doc-append (doc-empty "e") xp))
"<p>&lt;script&gt;alert(1)&lt;/script&gt;</p>")
(content-test
"no over-escape plain"
(asHTML (mk-text "plain" "hello world"))
"<p>hello world</p>")
(content-test
"escape code body"
(asHTML (mk-code "xc" "html" "<div> & </div>"))
"<pre><code class=\"language-html\">&lt;div&gt; &amp; &lt;/div&gt;</code></pre>")
;; ── asSx string-escaping (build expected via q/bs to avoid miscounts) ──
(define q1 (str "\""))
(define bs (str "\\"))
(content-test
"asSx escapes quote"
(asSx (mk-text "qt" (str "say " q1 "hi" q1)))
(str "(p " q1 "say " bs q1 "hi" bs q1 q1 ")"))
(content-test
"asSx escapes backslash"
(asSx (mk-text "qb" (str "a" bs "b")))
(str "(p " q1 "a" bs bs "b" q1 ")"))
(content-test
"asSx plain unchanged"
(asSx (mk-text "pp" "plain"))
"(p \"plain\")")
(content-test
"asSx escapes image attr"
(asSx (mk-image "im" (str "/a" q1) "x"))
(str "(img :src " q1 "/a" bs q1 q1 " :alt " q1 "x" q1 ")"))
(content-test
"asSx escapes list item"
(asSx (mk-list "lq" false (list (str "i" q1) "j")))
(str "(ul (li " q1 "i" bs q1 q1 ")(li " q1 "j" q1 "))"))

View File

@@ -0,0 +1,99 @@
;; Extension — nested block trees (CtSection container).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-markdown!)
(content-bootstrap-text!)
(content-bootstrap-section!)
(define nl (str "\n"))
;; ── a section is a block ──
(define
sec
(mk-section
"s"
(list (mk-heading "h" 2 "Hi") (mk-text "p" "Body"))))
(content-test "section is block" (block? sec) true)
(content-test "section? yes" (section? sec) true)
(content-test "section? no on text" (section? (mk-text "x" "y")) false)
(content-test "section type" (blk-type sec) "section")
(content-test "section id" (blk-id sec) "s")
(content-test
"section children count"
(len (section-children sec))
2)
;; ── recursive render ──
(content-test
"section html"
(asHTML sec)
"<section><h2>Hi</h2><p>Body</p></section>")
(content-test "section sx" (asSx sec) "(section (h2 \"Hi\")(p \"Body\"))")
(content-test "section text" (asText sec) "Hi Body")
(content-test
"empty section html"
(asHTML (mk-section "e" (list)))
"<section></section>")
;; ── nested in a document ──
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-heading "top" 1 "Top"))
sec))
(content-test
"doc with section html"
(asHTML d)
"<h1>Top</h1><section><h2>Hi</h2><p>Body</p></section>")
(content-test "doc top-level ids" (doc-ids d) (list "top" "s"))
;; ── arbitrary depth ──
(define
deep
(mk-section
"outer"
(list
(mk-text "a" "A")
(mk-section
"inner"
(list (mk-text "b" "B") (mk-heading "c" 3 "C"))))))
(content-test
"deep html"
(asHTML deep)
"<section><p>A</p><section><p>B</p><h3>C</h3></section></section>")
(content-test "deep text" (asText deep) "A B C")
;; ── tree traversal descends into sections ──
(define dd (doc-append (doc-empty "d") deep))
(content-test "deep-find nested" (blk-id (doc-deep-find dd "b")) "b")
(content-test
"deep-find deeper"
(str (blk-send (doc-deep-find dd "c") "text"))
"C")
(content-test "deep-find missing" (doc-deep-find dd "zzz") nil)
(content-test
"deep-find top-level"
(blk-id (doc-deep-find dd "outer"))
"outer")
(content-test
"tree-ids flattened"
(doc-tree-ids dd)
(list "outer" "a" "inner" "b" "c"))
(content-test "tree-count" (doc-tree-count dd) 5)
(content-test "top-level ids still flat" (doc-ids dd) (list "outer"))
;; ── copy-on-write child edits ──
(define sec2 (section-append sec (mk-divider "dv")))
(content-test "section-append" (len (section-children sec2)) 3)
(content-test
"section-append immutable"
(len (section-children sec))
2)
(content-test
"section-append renders"
(asHTML sec2)
"<section><h2>Hi</h2><p>Body</p><hr></section>")
;; ── markdown of a section (children joined by blank line) ──
(content-test "section markdown" (asMarkdown sec) (str "## Hi" nl nl "Body"))

View File

@@ -0,0 +1,100 @@
;; Extension — snapshot cache over op-log replay. The cache is transparent:
;; cached reads equal full replays.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(define B (persist/open))
(define h (mk-heading "h" 1 "T"))
(define p (mk-text "p" "Body"))
(define img (mk-image "img" "/c.png" "cat"))
(content/commit! B "post" (op-insert h nil) 1)
(content/commit! B "post" (op-insert p "h") 2)
(content/commit! B "post" (op-insert img "h") 3)
(content/commit! B "post" (op-update "p" "text" "Edited") 4)
;; ── no snapshot yet: cached == full replay ──
(content-test
"no snapshot head-cached == head"
(doc-ids (content/head-cached B "post"))
(doc-ids (content/head B "post")))
(content-test
"has-snapshot? false initially"
(content/has-snapshot? B "post")
false)
(content-test
"snapshot-seq 0 initially"
(content/snapshot-seq B "post")
0)
;; ── take a snapshot at seq 4 ──
(content-test "snapshot returns seq" (content/snapshot! B "post") 4)
(content-test "has-snapshot? true" (content/has-snapshot? B "post") true)
(content-test "snapshot-seq is 4" (content/snapshot-seq B "post") 4)
;; cached head equals full head right after snapshot
(content-test
"head-cached == head after snap"
(doc-ids (content/head-cached B "post"))
(list "h" "img" "p"))
(content-test
"head-cached p value"
(str (blk-send (doc-find (content/head-cached B "post") "p") "text"))
"Edited")
;; ── commit more after the snapshot; cached head replays only the tail ──
(content/commit! B "post" (op-delete "img") 5)
(content/commit! B "post" (op-insert (mk-text "q" "New") "p") 6)
(content-test
"head-cached reflects post-snapshot ops"
(doc-ids (content/head-cached B "post"))
(doc-ids (content/head B "post")))
(content-test
"head-cached order"
(doc-ids (content/head-cached B "post"))
(list "h" "p" "q"))
;; ── at-cached transparency across versions ──
(content-test
"at-cached seq2 (before snap) == at"
(doc-ids (content/at-cached B "post" 2))
(doc-ids (content/at B "post" 2)))
(content-test
"at-cached seq5 (after snap) == at"
(doc-ids (content/at-cached B "post" 5))
(doc-ids (content/at B "post" 5)))
(content-test
"at-cached seq6 == at"
(doc-ids (content/at-cached B "post" 6))
(doc-ids (content/at B "post" 6)))
(content-test
"at-cached seq4 == snapshot version"
(doc-ids (content/at-cached B "post" 4))
(list "h" "img" "p"))
;; ── re-snapshot moves the cache forward ──
(content-test "re-snapshot seq" (content/snapshot! B "post") 6)
(content-test
"head-cached still correct after resnap"
(doc-ids (content/head-cached B "post"))
(list "h" "p" "q"))
;; ── drop snapshot falls back to full replay, same result ──
(content/drop-snapshot! B "post")
(content-test "snapshot dropped" (content/has-snapshot? B "post") false)
(content-test
"head-cached == head after drop"
(doc-ids (content/head-cached B "post"))
(doc-ids (content/head B "post")))
;; ── snapshot of empty / fresh doc ──
(content-test
"snapshot empty doc seq 0"
(content/snapshot! B "empty")
0)
(content-test
"head-cached empty"
(doc-ids (content/head-cached B "empty"))
(list))

View File

@@ -0,0 +1,68 @@
;; Extension — document statistics.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-text!)
(content-bootstrap-section!)
;; ── empty doc ──
(define e (doc-empty "e"))
(content-test "empty words" (content/word-count e) 0)
(content-test "empty chars" (content/char-count e) 0)
(content-test "empty blocks" (content/block-count e) 0)
(content-test "empty reading" (content/reading-minutes e) 0)
(content-test "empty stats" (content/stats e) {:blocks 0 :reading-minutes 0 :words 0 :chars 0})
;; ── simple doc ──
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Hello World"))
(mk-text "p" "one two three")))
(content-test "word count" (content/word-count d) 5)
(content-test
"char count"
(content/char-count d)
(string-length "Hello World one two three"))
(content-test "block count" (content/block-count d) 2)
(content-test "reading rounds up" (content/reading-minutes d) 1)
;; ── reading time at 0 vs 1 word ──
(content-test
"one word one minute"
(content/reading-minutes (doc-append (doc-empty "d") (mk-text "p" "hi")))
1)
;; ── block count includes nested section children ──
(define
nested
(doc-append
(doc-empty "d")
(mk-section
"s"
(list (mk-heading "nh" 1 "A") (mk-text "np" "b c")))))
(content-test
"block count counts section + children"
(content/block-count nested)
3)
(content-test
"word count descends into section"
(content/word-count nested)
3)
;; ── deep nesting ──
(define
deep
(doc-append
(doc-empty "d")
(mk-section
"o"
(list (mk-text "a" "x") (mk-section "i" (list (mk-text "b" "y z")))))))
(content-test "deep block count" (content/block-count deep) 4)
(content-test "deep word count" (content/word-count deep) 3)
;; ── stats dict shape ──
(define s (content/stats d))
(content-test "stats words" (get s :words) 5)
(content-test "stats blocks" (get s :blocks) 2)
(content-test "stats has reading" (get s :reading-minutes) 1)

121
lib/content/tests/store.sx Normal file
View File

@@ -0,0 +1,121 @@
;; Phase 2 — op log + versioning over persist. The log is the source of truth;
;; any version is a replay of the op stream up to a seq.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(define B (persist/open))
(define h (mk-heading "h" 1 "Title"))
(define p (mk-text "p" "Body"))
(define img (mk-image "img" "/c.png" "cat"))
;; ── commit an op stream ──
(content/commit! B "post" (op-insert h nil) 10)
(content/commit! B "post" (op-insert p "h") 11)
(content/commit! B "post" (op-insert img "h") 12)
(content/commit! B "post" (op-update "p" "text" "Edited") 13)
(content/commit! B "post" (op-delete "img") 14)
(content-test "version-count" (content/version-count B "post") 5)
(content-test "log length" (len (content/log B "post")) 5)
;; ── head: latest materialised document ──
(content-test "head ids" (doc-ids (content/head B "post")) (list "h" "p"))
(content-test
"head p edited"
(str (blk-send (doc-find (content/head B "post") "p") "text"))
"Edited")
;; ── replay to any version ──
(content-test
"at seq1"
(doc-ids (content/at B "post" 1))
(list "h"))
(content-test
"at seq2"
(doc-ids (content/at B "post" 2))
(list "h" "p"))
(content-test
"at seq3"
(doc-ids (content/at B "post" 3))
(list "h" "img" "p"))
(content-test
"at seq3 p original"
(str (blk-send (doc-find (content/at B "post" 3) "p") "text"))
"Body")
(content-test
"at seq4 p edited"
(str (blk-send (doc-find (content/at B "post" 4) "p") "text"))
"Edited")
(content-test
"at seq5 img gone"
(doc-ids (content/at B "post" 5))
(list "h" "p"))
(content-test
"at seq0 empty"
(doc-ids (content/at B "post" 0))
(list))
;; ── ops accessor ──
(content-test
"ops kinds"
(map (fn (o) (get o :op)) (content/ops B "post"))
(list "insert" "insert" "insert" "update" "delete"))
;; ── history metadata ──
(define hist (content/history B "post"))
(content-test "history length" (len hist) 5)
(content-test "history first seq" (get (first hist) :seq) 1)
(content-test "history first type" (get (first hist) :type) "insert")
(content-test "history first at" (get (first hist) :at) 10)
(content-test
"history fourth type"
(get (nth hist 3) :type)
"update")
;; ── diff between versions ──
(define dvf (content/diff-versions B "post" 1 3))
(content-test "diff added" (get dvf :added) (list "img" "p"))
(content-test "diff removed empty" (get dvf :removed) (list))
(content-test "diff changed empty" (get dvf :changed) (list))
(define dvf2 (content/diff-versions B "post" 3 5))
(content-test "diff2 removed" (get dvf2 :removed) (list "img"))
(content-test "diff2 changed" (get dvf2 :changed) (list "p"))
(content-test "diff2 added empty" (get dvf2 :added) (list))
;; ── direct diff of two materialised docs ──
(define da (content/at B "post" 2))
(define db (content/at B "post" 5))
(content-test
"direct diff changed"
(get (content/diff da db) :changed)
(list "p"))
(content-test
"direct diff no-op"
(get (content/diff da da) :changed)
(list))
;; ── commit-all batch ──
(define B2 (persist/open))
(content/commit-all!
B2
"doc2"
(list (op-insert h nil) (op-insert p "h"))
1)
(content-test "commit-all count" (content/version-count B2 "doc2") 2)
(content-test
"commit-all head"
(doc-ids (content/head B2 "doc2"))
(list "h" "p"))
;; ── stream isolation ──
(content-test
"separate stream empty"
(content/version-count B "doc2")
0)
(content-test
"head of empty stream"
(doc-ids (content/head B "never"))
(list))

View File

@@ -0,0 +1,74 @@
;; Extension — list-card summary projection.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-text!)
(define
d
(doc-with-title
(doc-append
(doc-append
(doc-append (doc-empty "post") (mk-heading "h" 1 "Hello"))
(mk-text "p" "one two three four"))
(mk-image "img" "/cover.png" "cover"))
"My Post"))
;; image alt ("cover") is part of the plain-text projection, so it counts.
(define s (content/summary d))
(content-test "summary id" (get s :id) "post")
(content-test "summary title" (get s :title) "My Post")
(content-test
"summary excerpt"
(get s :excerpt)
"Hello one two three four cover")
(content-test "summary words" (get s :words) 6)
(content-test "summary reading" (get s :reading-minutes) 1)
(content-test "summary cover" (get s :cover) "/cover.png")
;; ── title falls back to id ──
(content-test
"summary title fallback"
(get
(content/summary (doc-append (doc-empty "x") (mk-text "p" "y")))
:title)
"x")
;; ── no image → cover nil ──
(content-test
"no cover"
(get
(content/summary (doc-append (doc-empty "x") (mk-text "p" "y")))
:cover)
nil)
(content-test "cover helper nil" (content/cover (doc-empty "e")) nil)
;; ── first image wins as cover ──
(define
d2
(doc-append
(doc-append (doc-empty "d") (mk-image "i1" "/a.png" "a"))
(mk-image "i2" "/b.png" "b")))
(content-test "first image cover" (content/cover d2) "/a.png")
;; ── empty doc ──
(define se (content/summary (doc-empty "e")))
(content-test "empty summary words" (get se :words) 0)
(content-test "empty summary excerpt" (get se :excerpt) "")
(content-test "empty summary cover" (get se :cover) nil)
;; ── excerpt truncates long content ──
(content-test
"excerpt truncated"
(>
(string-length
(get
(content/summary
(doc-append
(doc-empty "d")
(mk-text
"p"
"word word word word word word word word word word word word word word word word word word word word word word word word word word word word word word word word word")))
:excerpt))
100)
true)

74
lib/content/tests/sync.sx Normal file
View File

@@ -0,0 +1,74 @@
;; Phase 4 — external CMS sync via injected adapter. Import/export round-trip.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-render!)
;; ── a Ghost post (external shape) ──
(define post {:sections (list {:id "h" :text "Hello" :kind "heading" :level 1} {:id "p" :text "World" :kind "paragraph"} {:id "i" :src "/c.png" :alt "cat" :kind "image"} {:id "d" :kind "hr"} {:items (list "a" "b") :id "l" :kind "list" :ordered true}) :title "Hello"})
;; ── import (delegates to adapter) ──
(define doc (content/import ghost-adapter post "post"))
(content-test "import doc-id" (doc-id doc) "post")
(content-test "import ids" (doc-ids doc) (list "h" "p" "i" "d" "l"))
(content-test
"import types"
(doc-types doc)
(list "heading" "text" "image" "divider" "list"))
(content-test
"import renders"
(content/render doc "html")
"<h1>Hello</h1><p>World</p><img src=\"/c.png\" alt=\"cat\"><hr><ol><li>a</li><li>b</li></ol>")
(content-test
"import preserves heading level"
(blk-send (doc-find doc "h") "level")
1)
(content-test
"import preserves list items"
(blk-send (doc-find doc "l") "items")
(list "a" "b"))
;; ── export (delegates to adapter) ──
(define out (content/export ghost-adapter doc))
(content-test
"export sections round-trip"
(get out :sections)
(get post :sections))
;; ── round-trip: export then import yields the same document ──
(define doc2 (content/round-trip ghost-adapter doc))
(content-test "round-trip ids" (doc-ids doc2) (doc-ids doc))
(content-test
"round-trip render"
(content/render doc2 "html")
(content/render doc "html"))
;; ── round-trip the external form: import . export . import == import ──
(content-test
"external round-trip sections"
(get
(content/export ghost-adapter (content/import ghost-adapter post "post"))
:sections)
(get post :sections))
;; ── core knows nothing about Ghost: a different (stub) adapter works the same ──
(define raw-adapter {:export (fn (d) (str (blk-send (doc-find d "only") "text"))) :import (fn (ext doc-id) (doc-new doc-id (list (mk-text "only" ext))))})
(define rdoc (content/import raw-adapter "just text" "r"))
(content-test "alt adapter import" (doc-ids rdoc) (list "only"))
(content-test
"alt adapter export"
(content/export raw-adapter rdoc)
"just text")
;; ── code / quote / embed kinds round-trip ──
(define post2 {:sections (list {:id "c" :text "(+ 1 2)" :kind "code" :language "sx"} {:cite "Ada" :id "q" :text "to err" :kind "quote"} {:id "e" :provider "vimeo" :kind "embed" :url "https://v/1"})})
(define d3 (content/import ghost-adapter post2 "p2"))
(content-test
"code/quote/embed types"
(doc-types d3)
(list "code" "quote" "embed"))
(content-test
"code/quote/embed round-trip"
(get (content/export ghost-adapter d3) :sections)
(get post2 :sections))

View File

@@ -0,0 +1,77 @@
;; Extension — table block.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-markdown!)
(content-bootstrap-text!)
(content-bootstrap-table!)
(define nl (str "\n"))
(define
t
(mk-table
"t"
(list "Name" "Age")
(list (list "Ada" "36") (list "Al" "40"))))
;; ── identity ──
(content-test "table is block" (block? t) true)
(content-test "table? yes" (table? t) true)
(content-test "table type" (blk-type t) "table")
(content-test "table headers" (table-headers t) (list "Name" "Age"))
(content-test "table rows" (len (table-rows t)) 2)
;; ── html ──
(content-test
"table html"
(asHTML t)
"<table><thead><tr><th>Name</th><th>Age</th></tr></thead><tbody><tr><td>Ada</td><td>36</td></tr><tr><td>Al</td><td>40</td></tr></tbody></table>")
(content-test
"table html escapes cells"
(asHTML (mk-table "t" (list "A<B") (list (list "x&y"))))
"<table><thead><tr><th>A&lt;B</th></tr></thead><tbody><tr><td>x&amp;y</td></tr></tbody></table>")
;; ── sx ──
(content-test
"table sx"
(asSx t)
"(table (thead (tr (th \"Name\")(th \"Age\"))) (tbody (tr (td \"Ada\")(td \"36\"))(tr (td \"Al\")(td \"40\"))))")
;; ── text ──
(content-test "table text" (asText t) "Name Age Ada 36 Al 40")
;; ── markdown ──
(content-test
"table markdown"
(asMarkdown t)
(str "| Name | Age |" nl "| --- | --- |" nl "| Ada | 36 |" nl "| Al | 40 |"))
;; ── in a document ──
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Data"))
t))
(content-test
"doc with table html"
(asHTML d)
"<h1>Data</h1><table><thead><tr><th>Name</th><th>Age</th></tr></thead><tbody><tr><td>Ada</td><td>36</td></tr><tr><td>Al</td><td>40</td></tr></tbody></table>")
(content-test "doc ids" (doc-ids d) (list "h" "t"))
;; ── empty rows ──
(content-test
"table no rows html"
(asHTML (mk-table "t" (list "H") (list)))
"<table><thead><tr><th>H</th></tr></thead><tbody></tbody></table>")
;; ── validation ──
(content-test
"valid table"
(content/valid? (doc-append (doc-empty "d") t))
true)
(content-test
"bad headers flagged"
(content/issue-kinds
(doc-append (doc-empty "d") (mk-table "t" "nope" (list))))
(list "field"))

72
lib/content/tests/text.sx Normal file
View File

@@ -0,0 +1,72 @@
;; Extension — plain-text render mode + excerpts.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-text!)
;; ── per-block ──
(content-test
"heading text"
(asText (mk-heading "h" 2 "Title"))
"Title")
(content-test "paragraph text" (asText (mk-text "p" "Body")) "Body")
(content-test "code text" (asText (mk-code "c" "sx" "(+ 1 2)")) "(+ 1 2)")
(content-test "quote text" (asText (mk-quote "q" "Ada" "to err")) "to err")
(content-test
"image -> alt"
(asText (mk-image "i" "/c.png" "a cat"))
"a cat")
(content-test
"embed -> empty"
(asText (mk-embed "e" "https://v" "vimeo"))
"")
(content-test "divider -> empty" (asText (mk-divider "d")) "")
(content-test
"list -> joined"
(asText (mk-list "l" false (list "a" "b" "c")))
"a, b, c")
(content-test "empty list -> empty" (asText (mk-list "l" false (list))) "")
;; ── document joins non-empty child texts with a space ──
(define
d
(doc-append
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Title"))
(mk-text "p" "Hello world"))
(mk-divider "dv"))
(mk-list "l" true (list "x" "y"))))
(content-test "doc text skips empties" (asText d) "Title Hello world x, y")
(content-test "empty doc text" (asText (doc-empty "e")) "")
;; ── via facade ──
(content-test "render text" (content/render d "text") (asText d))
(content-test "render text keyword" (content/render d :text) (asText d))
(content-test "content/text alias" (content/text d) (asText d))
(content-test "block-text alias" (block-text (mk-text "p" "x")) "x")
;; ── excerpt ──
(content-test
"excerpt under limit"
(content/excerpt d 100)
"Title Hello world x, y")
(content-test "excerpt truncates" (content/excerpt d 5) "Title…")
(content-test
"excerpt exact length"
(content/excerpt
(doc-append (doc-empty "e") (mk-text "p" "12345"))
5)
"12345")
(content-test
"excerpt one over"
(content/excerpt
(doc-append (doc-empty "e") (mk-text "p" "123456"))
5)
"12345…")
;; ── reflects edits ──
(content-test
"text after update"
(asText (doc-update d "p" "text" "Changed"))
"Title Changed x, y")

63
lib/content/tests/toc.sx Normal file
View File

@@ -0,0 +1,63 @@
;; Extension — table-of-contents rendering.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(define nl (str "\n"))
(define
d
(doc-append
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "intro" 1 "Intro"))
(mk-text "p" "x"))
(mk-heading "bg" 2 "Background"))
(mk-section "s" (list (mk-heading "deep" 2 "Details")))))
;; ── markdown TOC (indented by level) ──
(content-test
"toc markdown"
(content/toc-markdown d)
(str
"- [Intro](#intro)"
nl
" - [Background](#bg)"
nl
" - [Details](#deep)"))
;; ── html TOC (anchor links) ──
(content-test
"toc html"
(content/toc-html d)
"<ul><li><a href=\"#intro\">Intro</a></li><li><a href=\"#bg\">Background</a></li><li><a href=\"#deep\">Details</a></li></ul>")
;; ── html escapes heading text ──
(content-test
"toc html escapes"
(content/toc-html
(doc-append (doc-empty "d") (mk-heading "h" 1 "A < B")))
"<ul><li><a href=\"#h\">A &lt; B</a></li></ul>")
;; ── empty / no headings ──
(content-test "toc html empty" (content/toc-html (doc-empty "e")) "")
(content-test "toc markdown empty" (content/toc-markdown (doc-empty "e")) "")
(content-test
"toc no headings"
(content/toc-html (doc-append (doc-empty "d") (mk-text "p" "just text")))
"")
;; ── single heading ──
(content-test
"toc single md"
(content/toc-markdown
(doc-append (doc-empty "d") (mk-heading "h" 1 "Only")))
"- [Only](#h)")
;; ── deep level indentation ──
(content-test
"toc deep indent"
(content/toc-markdown
(doc-append (doc-empty "d") (mk-heading "h" 3 "Deep")))
" - [Deep](#h)")

View File

@@ -0,0 +1,90 @@
;; Extension — tree-wide block transforms.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Top"))
(mk-section
"s"
(list (mk-text "a" "A") (mk-heading "h2" 2 "Sub")))))
;; ── map-type bumps heading levels everywhere ──
(define
d1
(content/map-type
d
"heading"
(fn (b) (blk-set b "level" (+ (blk-get b "level") 1)))))
(content-test
"map-type top heading"
(blk-send (doc-deep-find d1 "h") "level")
2)
(content-test
"map-type nested heading"
(blk-send (doc-deep-find d1 "h2") "level")
3)
(content-test
"map-type leaves text"
(str (blk-send (doc-deep-find d1 "a") "text"))
"A")
(content-test
"map-type immutable"
(blk-send (doc-deep-find d "h") "level")
1)
(content-test "map-type preserves tree" (doc-tree-ids d1) (doc-tree-ids d))
;; ── set-field-on rewrites all text blocks ──
(define d2 (content/set-field-on d "text" "text" "REDACTED"))
(content-test
"set-field nested text"
(str (blk-send (doc-deep-find d2 "a") "text"))
"REDACTED")
(content-test
"set-field count"
(len
(filter
(fn (b) (= (str (blk-get b "text")) "REDACTED"))
(list (doc-deep-find d2 "a"))))
1)
;; ── map-blocks with custom predicate ──
(define
d3
(content/map-blocks
d
(fn (b) (= (blk-id b) "h2"))
(fn (b) (blk-set b "text" "Changed"))))
(content-test
"map-blocks predicate hit"
(str (blk-send (doc-deep-find d3 "h2") "text"))
"Changed")
(content-test
"map-blocks predicate miss"
(str (blk-send (doc-deep-find d3 "h") "text"))
"Top")
;; ── image src rewrite (cdn migration) ──
(define di (doc-append (doc-empty "d") (mk-image "img" "/old.png" "x")))
(content-test
"image src rewrite"
(str
(blk-send
(doc-find (content/set-field-on di "image" "src" "/cdn/new.png") "img")
"src"))
"/cdn/new.png")
;; ── no matching blocks → unchanged ──
(content-test
"no match unchanged"
(asHTML (content/map-type d "embed" (fn (b) b)))
(asHTML d))
;; ── render after transform ──
(content-test
"render after map-type"
(asHTML d1)
"<h2>Top</h2><section><p>A</p><h3>Sub</h3></section>")

View File

@@ -0,0 +1,91 @@
;; Extension — deep tree editing (update/delete/insert into nested sections).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
;; doc: top / sec[ a, inner[ b ] ]
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-text "top" "T"))
(mk-section
"sec"
(list
(mk-text "a" "A")
(mk-section "inner" (list (mk-text "b" "B")))))))
;; ── deep-update a nested block ──
(define d1 (doc-deep-update d "b" "text" "Edited"))
(content-test
"deep-update nested"
(str (blk-send (doc-deep-find d1 "b") "text"))
"Edited")
(content-test
"deep-update immutable"
(str (blk-send (doc-deep-find d "b") "text"))
"B")
(content-test
"deep-update top-level"
(str
(blk-send
(doc-deep-find (doc-deep-update d "top" "text" "X") "top")
"text"))
"X")
(content-test
"deep-update mid-section"
(str
(blk-send (doc-deep-find (doc-deep-update d "a" "text" "AA") "a") "text"))
"AA")
(content-test
"deep-update preserves tree"
(doc-tree-ids d1)
(doc-tree-ids d))
;; ── deep-replace ──
(define d2 (doc-deep-replace d "b" (mk-heading "b" 3 "H")))
(content-test
"deep-replace type"
(blk-type (doc-deep-find d2 "b"))
"heading")
(content-test
"deep-replace render"
(asHTML d2)
"<p>T</p><section><p>A</p><section><h3>H</h3></section></section>")
;; ── deep-delete ──
(define d3 (doc-deep-delete d "b"))
(content-test "deep-delete removes nested" (doc-deep-find d3 "b") nil)
(content-test
"deep-delete tree-ids"
(doc-tree-ids d3)
(list "top" "sec" "a" "inner"))
(content-test "deep-delete immutable" (doc-tree-count d) 5)
(content-test
"deep-delete mid-section"
(doc-tree-ids (doc-deep-delete d "a"))
(list "top" "sec" "inner" "b"))
(content-test
"deep-delete top-level"
(doc-tree-ids (doc-deep-delete d "top"))
(list "sec" "a" "inner" "b"))
;; ── deep-insert-into a nested section ──
(define d4 (doc-deep-insert-into d "inner" (mk-text "c" "C")))
(content-test
"insert-into nested"
(doc-tree-ids d4)
(list "top" "sec" "a" "inner" "b" "c"))
(content-test
"insert-into found"
(str (blk-send (doc-deep-find d4 "c") "text"))
"C")
(content-test
"insert-into outer section"
(doc-tree-ids (doc-deep-insert-into d "sec" (mk-divider "dv")))
(list "top" "sec" "a" "inner" "b" "dv"))
(content-test "insert-into immutable" (doc-tree-count d) 5)
(content-test
"insert-into render"
(asHTML d4)
"<p>T</p><section><p>A</p><section><p>B</p><p>C</p></section></section>")

View File

@@ -0,0 +1,166 @@
;; Extension — document integrity validation (tree-aware: descends into sections).
;; (Conformance loads section.sx before this suite.)
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-section!)
;; ── a fully valid document ──
(define
good
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Title"))
(mk-text "p" "Body"))
(mk-list "l" true (list "a" "b"))))
(content-test "valid doc is valid" (content/valid? good) true)
(content-test "valid doc no issues" (content/validate good) (list))
;; ── bad field types ──
(content-test
"heading bad level"
(content/issue-kinds
(doc-append (doc-empty "d") (mk-heading "h" "notnum" "T")))
(list "field"))
(content-test
"text bad type"
(content/issue-kinds
(doc-append (doc-empty "d") (mk-text "p" 42)))
(list "field"))
(content-test
"image two bad attrs"
(len
(content/validate
(doc-append (doc-empty "d") (mk-image "i" 1 2))))
2)
(content-test
"list bad ordered + items"
(len
(content/validate
(doc-append (doc-empty "d") (mk-list "l" "yes" "nope"))))
2)
(content-test
"valid image ok"
(content/valid?
(doc-append (doc-empty "d") (mk-image "i" "/a.png" "alt")))
true)
;; ── id checks ──
(content-test
"blank id"
(content/issue-kinds (doc-append (doc-empty "d") (mk-text "" "x")))
(list "id"))
(content-test
"nil id"
(content/issue-kinds
(doc-append (doc-empty "d") (blk-set (mk-text "x" "y") "id" nil)))
(list "id"))
;; ── duplicate ids ──
(define
dup
(doc-append
(doc-append (doc-empty "d") (mk-text "x" "a"))
(mk-text "x" "b")))
(content-test
"duplicate id detected"
(content/issue-kinds dup)
(list "duplicate"))
(content-test
"duplicate reported once"
(len
(filter (fn (i) (= (get i :kind) "duplicate")) (content/validate dup)))
1)
(content-test "duplicate not valid" (content/valid? dup) false)
;; ── unknown block type (raw base instance) ──
(define raw (st-iv-set! (st-make-instance "CtBlock") "id" "z"))
(content-test
"unknown type flagged"
(content/issue-kinds (doc-append (doc-empty "d") raw))
(list "type"))
;; ── issue carries id + detail ──
(define
iss
(first
(content/validate
(doc-append (doc-empty "d") (mk-text "bad" 9)))))
(content-test "issue has id" (get iss :id) "bad")
(content-test "issue has detail" (string? (get iss :detail)) true)
;; ── multiple issues across blocks accumulate ──
(define
messy
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" "x" "ok"))
(mk-text "" 5)))
(content-test
"issues accumulate"
(> (len (content/validate messy)) 2)
true)
;; ── all block types valid when well-formed ──
(define
allgood
(doc-append
(doc-append
(doc-append
(doc-append
(doc-append
(doc-append (doc-empty "d") (mk-code "c" "sx" "(+ 1 2)"))
(mk-quote "q" "Ada" "to err"))
(mk-embed "e" "https://v" "vimeo"))
(mk-divider "dv"))
(mk-heading "hh" 2 "H"))
(mk-text "tt" "T")))
(content-test "all well-formed types valid" (content/valid? allgood) true)
;; ── tree-aware: descends into sections ──
(define
nested
(doc-append
(doc-empty "d")
(mk-section
"s"
(list (mk-heading "nh" 1 "H") (mk-text "np" "ok")))))
(content-test "valid nested section" (content/valid? nested) true)
(define
nested-bad
(doc-append
(doc-empty "d")
(mk-section "s" (list (mk-heading "nh" "notnum" "H")))))
(content-test
"nested bad field detected"
(content/issue-kinds nested-bad)
(list "field"))
;; valid section block itself
(content-test
"section valid"
(content/valid? (doc-append (doc-empty "d") (mk-section "s" (list))))
true)
(content-test
"section bad children"
(content/issue-kinds
(doc-append
(doc-empty "d")
(st-iv-set! (mk-section "s" (list)) "children" "nope")))
(list "field"))
;; duplicate id across a section boundary (top-level id == nested id)
(define
dup-tree
(doc-append
(doc-append (doc-empty "d") (mk-text "x" "top"))
(mk-section "s" (list (mk-text "x" "nested")))))
(content-test
"tree-wide duplicate detected"
(len
(filter
(fn (i) (= (get i :kind) "duplicate"))
(content/validate dup-tree)))
1)
(content-test "tree dup not valid" (content/valid? dup-tree) false)

63
lib/content/tests/wire.sx Normal file
View File

@@ -0,0 +1,63 @@
;; Extension — on-the-wire serialization (to-wire / from-wire).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-text!)
(content-bootstrap-section!)
(content-bootstrap-table!)
(define
d
(doc-with-meta
(doc-append
(doc-append (doc-empty "post") (mk-heading "h" 1 "Title"))
(mk-text "p" "Body text"))
{:title "T" :tags (list "x" "y")}))
;; ── to-wire produces a string ──
(content-test "to-wire is string" (string? (content/to-wire d)) true)
;; ── parse(to-wire) == data form ──
(content-test
"wire parses to data"
(parse (content/to-wire d))
(content/to-data d))
;; ── round-trip preserves everything ──
(define rt (content/wire-round-trip d))
(content-test "rt id" (doc-id rt) "post")
(content-test "rt title" (doc-title rt) "T")
(content-test "rt tags" (doc-tags rt) (list "x" "y"))
(content-test "rt ids" (doc-ids rt) (list "h" "p"))
(content-test "rt render" (asHTML rt) (asHTML d))
;; ── nested + table survive the wire ──
(define
dn
(doc-append
(doc-append
(doc-empty "d")
(mk-section "s" (list (mk-text "a" "deep"))))
(mk-table "t" (list "A") (list (list "1")))))
(content-test
"wire nested render"
(asHTML (content/wire-round-trip dn))
(asHTML dn))
(content-test
"wire nested tree-ids"
(doc-tree-ids (content/wire-round-trip dn))
(doc-tree-ids dn))
;; ── empty doc ──
(content-test
"wire empty"
(doc-ids (content/from-wire (content/to-wire (doc-empty "e"))))
(list))
;; ── from-wire of an externally-built wire string ──
(content-test
"from-wire external"
(asHTML
(content/from-wire
"{:id \"x\" :blocks ({:id \"h\" :type \"heading\" :fields {:level 2 :text \"Hi\"}})}"))
"<h2>Hi</h2>")

46
lib/content/text.sx Normal file
View File

@@ -0,0 +1,46 @@
;; content-on-sx — plain-text render mode + excerpts.
;;
;; A fourth boundary format via polymorphic dispatch: blocks answer asText,
;; stripping all markup. Useful for search indexing, meta descriptions and
;; previews. The document joins non-empty child texts with a single space.
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define
content-bootstrap-text!
(fn
()
(begin
(ct-def-method! "CtHeading" "asText" "asText ^ text")
(ct-def-method! "CtText" "asText" "asText ^ text")
(ct-def-method! "CtCode" "asText" "asText ^ text")
(ct-def-method! "CtQuote" "asText" "asText ^ text")
(ct-def-method! "CtImage" "asText" "asText ^ alt")
(ct-def-method! "CtEmbed" "asText" "asText ^ ''")
(ct-def-method! "CtDivider" "asText" "asText ^ ''")
(ct-def-method!
"CtList"
"asText"
"asText ^ (items inject: '' into: [:a :x | (a = '' ifTrue: [x] ifFalse: [a , ', ' , x])])")
(ct-def-method!
"CtDoc"
"asText"
"asText ^ (blocks inject: '' into: [:a :b | (b asText = '') ifTrue: [a] ifFalse: [(a = '' ifTrue: [b asText] ifFalse: [a , ' ' , b asText])]])")
true)))
;; ── SX boundary ──
(define asText (fn (node) (str (st-send node "asText" (list)))))
(define content/text asText)
(define block-text asText)
;; excerpt: first n chars of the plain text, with an ellipsis if truncated.
(define
content/excerpt
(fn
(doc n)
(let
((t (asText doc)))
(if
(<= (string-length t) n)
t
(str (substring t 0 n) "…")))))

68
lib/content/toc.sx Normal file
View File

@@ -0,0 +1,68 @@
;; content-on-sx — table-of-contents rendering.
;;
;; Turns content/headings into a user-facing TOC: a Markdown bullet list indented
;; by heading level, and an HTML <ul> of anchor links (#id). The blog page links
;; these to heading anchors.
;;
;; Requires (loaded by harness): query.sx (content/headings), render.sx
;; (htmlEscaped).
(define toc-nl (str "\n"))
(define
toc-join
(fn
(sep parts)
(cond
((= (len parts) 0) "")
((= (len parts) 1) (first parts))
(else (str (first parts) sep (toc-join sep (rest parts)))))))
(define
toc-indent
(fn
(n)
(if (<= n 0) "" (str " " (toc-indent (- n 1))))))
(define toc-esc (fn (s) (str (st-send s "htmlEscaped" (list)))))
(define
content/toc-markdown
(fn
(doc)
(toc-join
toc-nl
(map
(fn
(h)
(str
(toc-indent (- (get h :level) 1))
"- ["
(get h :text)
"](#"
(get h :id)
")"))
(content/headings doc)))))
(define
content/toc-html
(fn
(doc)
(let
((hs (content/headings doc)))
(if
(= (len hs) 0)
""
(str
"<ul>"
(toc-join
""
(map
(fn
(h)
(str
"<li><a href=\"#"
(get h :id)
"\">"
(toc-esc (get h :text))
"</a></li>"))
hs))
"</ul>")))))

52
lib/content/transform.sx Normal file
View File

@@ -0,0 +1,52 @@
;; content-on-sx — tree-wide block transforms.
;;
;; The write counterpart to query: apply a function to every matching block
;; across the tree (descending into sections), returning a new document. For
;; bulk edits — rewrite image srcs, bump heading levels, sanitise text. Tree
;; detection/rebuild is inline (class + st-iv-get/set!) so this needs no
;; section.sx. Immutable.
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define
xf-section?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define
block-tree-transform
(fn
(blocks pred f)
(map
(fn
(b)
(let
((nb (if (pred b) (f b) b)))
(if
(xf-section? nb)
(let
((ch (st-iv-get nb "children")))
(if
(list? ch)
(st-iv-set! nb "children" (block-tree-transform ch pred f))
nb))
nb)))
blocks)))
(define
content/map-blocks
(fn
(doc pred f)
(doc-with-blocks doc (block-tree-transform (doc-blocks doc) pred f))))
(define
content/map-type
(fn
(doc type f)
(content/map-blocks doc (fn (b) (= (blk-type b) type)) f)))
;; convenience: set a field on every block of a type.
(define
content/set-field-on
(fn
(doc type field value)
(content/map-type doc type (fn (b) (blk-set b field value)))))

96
lib/content/tree-edit.sx Normal file
View File

@@ -0,0 +1,96 @@
;; content-on-sx — deep tree editing.
;;
;; Mutate blocks anywhere in the nested tree (descending into CtSection children),
;; complementing the top-level doc ops and the deep-find read path. All return
;; new documents (immutable).
;;
;; Requires (loaded by harness): doc.sx, section.sx (section? / section-children /
;; section-with-children / section-append).
;; map f over every block in the tree, replacing the one whose id matches.
(define
block-tree-update
(fn
(blocks id f)
(map
(fn
(b)
(if
(= (blk-id b) id)
(f b)
(if
(section? b)
(section-with-children
b
(block-tree-update (section-children b) id f))
b)))
blocks)))
;; remove the block with id from anywhere in the tree.
(define
block-tree-delete
(fn
(blocks id)
(map
(fn
(b)
(if
(section? b)
(section-with-children
b
(block-tree-delete (section-children b) id))
b))
(filter (fn (b) (if (= (blk-id b) id) false true)) blocks))))
;; append a block into the children of the section with section-id.
(define
block-tree-insert-into
(fn
(blocks section-id block)
(map
(fn
(b)
(if
(section? b)
(if
(= (blk-id b) section-id)
(section-append b block)
(section-with-children
b
(block-tree-insert-into (section-children b) section-id block)))
b))
blocks)))
;; ── document-level deep ops ──
(define
doc-deep-update
(fn
(doc id field value)
(doc-with-blocks
doc
(block-tree-update
(doc-blocks doc)
id
(fn (b) (blk-set b field value))))))
(define
doc-deep-replace
(fn
(doc id newblock)
(doc-with-blocks
doc
(block-tree-update (doc-blocks doc) id (fn (b) newblock)))))
(define
doc-deep-delete
(fn
(doc id)
(doc-with-blocks doc (block-tree-delete (doc-blocks doc) id))))
(define
doc-deep-insert-into
(fn
(doc section-id block)
(doc-with-blocks
doc
(block-tree-insert-into (doc-blocks doc) section-id block))))

218
lib/content/validate.sx Normal file
View File

@@ -0,0 +1,218 @@
;; content-on-sx — document integrity validation.
;;
;; Guards imports, edits and federated input: walks the whole block TREE (into
;; nested sections) checking each block's id and required fields/types, plus
;; tree-wide duplicate ids. Returns issue dicts {:id :kind :detail}; empty = ok.
;; Tree detection is inline (class + st-iv-get) so this file needs no section.sx.
;; Dispatch on block type is a validation-boundary concern, not core behaviour.
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define ct-issue (fn (id kind detail) {:id id :detail detail :kind kind}))
(define
ct-flatmap
(fn
(f xs)
(if
(= (len xs) 0)
(list)
(append (f (first xs)) (ct-flatmap f (rest xs))))))
(define ct-count-in (fn (x xs) (len (filter (fn (y) (= y x)) xs))))
;; dedup, order-preserving (keep first occurrence)
(define
ct-uniq-loop
(fn
(xs seen)
(if
(= (len xs) 0)
(reverse seen)
(if
(> (ct-count-in (first xs) seen) 0)
(ct-uniq-loop (rest xs) seen)
(ct-uniq-loop (rest xs) (cons (first xs) seen))))))
(define ct-uniq (fn (xs) (ct-uniq-loop xs (list))))
;; ── tree flatten (descends into CtSection children; guards malformed children) ──
(define
ct-section-block?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define
ct-tree-blocks
(fn
(blocks)
(if
(= (len blocks) 0)
(list)
(let
((b (first blocks)))
(append
(cons
b
(if
(ct-section-block? b)
(let
((ch (st-iv-get b "children")))
(if (list? ch) (ct-tree-blocks ch) (list)))
(list)))
(ct-tree-blocks (rest blocks)))))))
;; ── id checks ──
(define
content/-id-issues
(fn
(b)
(let
((id (blk-id b)))
(if
(and (string? id) (> (len id) 0))
(list)
(list (ct-issue id "id" "block id must be a non-empty string"))))))
(define
ct-field-issue
(fn (id ok? what) (if ok? (list) (list (ct-issue id "field" what)))))
;; ── per-type field checks ──
(define
content/-field-issues
(fn
(b)
(let
((t (blk-type b)) (id (blk-id b)))
(cond
((= t "heading")
(append
(ct-field-issue
id
(number? (blk-get b "level"))
"heading level must be a number")
(ct-field-issue
id
(string? (blk-get b "text"))
"heading text must be a string")))
((= t "text")
(ct-field-issue
id
(string? (blk-get b "text"))
"text must be a string"))
((= t "code")
(append
(ct-field-issue
id
(string? (blk-get b "language"))
"code language must be a string")
(ct-field-issue
id
(string? (blk-get b "text"))
"code text must be a string")))
((= t "quote")
(ct-field-issue
id
(string? (blk-get b "text"))
"quote text must be a string"))
((= t "image")
(append
(ct-field-issue
id
(string? (blk-get b "src"))
"image src must be a string")
(ct-field-issue
id
(string? (blk-get b "alt"))
"image alt must be a string")))
((= t "embed")
(append
(ct-field-issue
id
(string? (blk-get b "url"))
"embed url must be a string")
(ct-field-issue
id
(string? (blk-get b "provider"))
"embed provider must be a string")))
((= t "divider") (list))
((= t "list")
(append
(ct-field-issue
id
(boolean? (blk-get b "ordered"))
"list ordered must be a boolean")
(ct-field-issue
id
(list? (blk-get b "items"))
"list items must be a list")))
((= t "section")
(ct-field-issue
id
(list? (blk-get b "children"))
"section children must be a list"))
((= t "table")
(append
(ct-field-issue
id
(list? (blk-get b "headers"))
"table headers must be a list")
(ct-field-issue
id
(list? (blk-get b "rows"))
"table rows must be a list")))
((= t "callout")
(append
(ct-field-issue
id
(string? (blk-get b "kind"))
"callout kind must be a string")
(ct-field-issue
id
(string? (blk-get b "text"))
"callout text must be a string")))
((= t "media")
(append
(ct-field-issue
id
(if
(= (blk-get b "kind") "video")
true
(= (blk-get b "kind") "audio"))
"media kind must be video or audio")
(ct-field-issue
id
(string? (blk-get b "src"))
"media src must be a string")))
(else (list (ct-issue id "type" (str "unknown block type: " t))))))))
(define
content/-block-issues
(fn (b) (append (content/-id-issues b) (content/-field-issues b))))
;; ── duplicate ids across the whole tree ──
(define
content/-dup-issues
(fn
(ids)
(map
(fn (id) (ct-issue id "duplicate" (str "duplicate block id: " id)))
(ct-uniq (filter (fn (id) (> (ct-count-in id ids) 1)) ids)))))
;; ── public ──
(define
content/validate
(fn
(doc)
(let
((all (ct-tree-blocks (doc-blocks doc))))
(append
(content/-dup-issues (map (fn (b) (blk-id b)) all))
(ct-flatmap content/-block-issues all)))))
(define
content/valid?
(fn (doc) (= (len (content/validate doc)) 0)))
(define
content/issue-kinds
(fn (doc) (map (fn (i) (get i :kind)) (content/validate doc))))

14
lib/content/wire.sx Normal file
View File

@@ -0,0 +1,14 @@
;; content-on-sx — on-the-wire serialization.
;;
;; content/to-wire serialises a document to a transmittable SX-text string (via
;; the data form + the SX serializer); content/from-wire parses it back into a
;; live document. This is the format to persist a whole document or send it over
;; HTTP / federation, distinct from the per-op persist log.
;;
;; Requires (loaded by harness): data.sx (content/to-data / content/from-data).
(define content/to-wire (fn (doc) (serialize (content/to-data doc))))
(define content/from-wire (fn (s) (content/from-data (parse s))))
(define
content/wire-round-trip
(fn (doc) (content/from-wire (content/to-wire doc))))

View File

@@ -0,0 +1,112 @@
# commerce-on-sx loop agent (single agent, phase-ordered)
Role: iterates `plans/commerce-on-sx.md` forever. **Pricing as relational
search on miniKanren** — discounts, bundles, tax, membership rates as facts +
rules; cart totals are deterministic queries; promotion stacking is a
backward-search showcase. Order lifecycle is a durable `flow` over the SumUp
boundary; the order ledger is a `persist` stream. **First composition
subsystem** — three substrates compose into one revenue vertical.
```
description: commerce-on-sx phase loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash-loops/commerce/plans/commerce-on-sx.md`.
Isolated worktree, forever, one commit per feature. Push to
`origin/loops/commerce` after every commit. Never `main`, never `architecture`.
## Restart baseline — check before iterating
1. Read `plans/commerce-on-sx.md` — Phase queue + Progress log + Blockers.
2. `ls lib/commerce/` — pick up from the most advanced file.
3. If `lib/commerce/tests/*.sx` exist, run them via
`bash lib/commerce/conformance.sh`. Green before new work.
4. Read `lib/minikanren/minikanren.sx` public API once — that's your engine.
5. Check substrate readiness:
- `bash lib/minikanren/conformance.sh` — must be green
- `lib/persist/persist.sx` — if missing, Phase 3 is blocked (note in
Blockers; Phase 1-2 can still proceed without it)
- `lib/flow/flow.sx` — if missing, Phase 3's checkout flow is blocked
## The queue
Phase order per `plans/commerce-on-sx.md`:
- **Phase 1** — catalog + cart + deterministic totals
- **Phase 2** — promotions as miniKanren relations, stacking precedence
- **Phase 3** — order lifecycle as a durable `flow` (reserve → pay → fulfil)
- **Phase 4** — reconciliation + federation stubs
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → no-regression gate → commit → tick `[ ]`
→ append dated Progress log line (newest first) → push → stop.
## Ground rules (hard)
- **Scope:** only `lib/commerce/**` and `plans/commerce-on-sx.md`. Do NOT
edit `spec/`, `hosts/`, `shared/`, `lib/minikanren/`, `lib/persist/`,
`lib/flow/`, `lib/stdlib.sx`, or `lib/` root. May **import** from
`lib/minikanren/`, and once they exist `lib/persist/` + `lib/flow/`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken →
Blockers entry, stop.
- **Money is integer minor units.** No floats anywhere. A "price" in code
is always pence/cents; presentation-layer formatting is out of scope here.
- **Determinism is the contract.** Promotion stacking must have an
explicit, tested precedence. Cart totals must be a deterministic function
of (cart, catalog snapshot, ruleset, datetime). The same inputs must
produce identical outputs across runs.
- **Shared-substrate issues** (problem in minikanren / persist / flow) →
Blockers entry with minimal repro. Do NOT patch around it.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit, push to `origin/loops/commerce`. Never touch `main`
or `architecture`.
- **Commit granularity:** one feature per commit. Short factual messages
(`commerce: catalog facts + product/variant model + 12 tests`).
- **Plan file:** update Progress log + tick boxes every commit.
## Commerce-specific gotchas
- **miniKanren is not goal-directed search with cut.** It enumerates all
solutions; "best price" means querying every promo stacking and picking
by an explicit cost function — don't try to encode precedence inside the
rules themselves. Use a separate selection layer.
- **Tax is jurisdiction-relational.** Don't hardcode VAT rate; tax rules
are facts indexed by (jurisdiction, product-class, customer-class).
- **Idempotency matters for orders.** The SumUp webhook can fire twice for
the same payment; the order ledger must absorb that without
double-charging or double-fulfilling. Idempotency keys live in `persist`.
- **Flow suspension at payment boundary.** Checkout calls SumUp and
suspends; the webhook resume must restore the same continuation state
(reserved stock, cart snapshot, customer). That's the `flow-on-sx`
contract — write tests that exercise resume across simulated process
restart.
- **Backward queries are the showcase.** "Which promo yields this total?"
and "Which line item triggered this discount?" should be miniKanren
queries with `run-1` / `run-all`, not separate code paths. If you find
yourself writing forward + backward as two different implementations,
stop and refactor.
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr — wrap multiples
in `begin`.
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks
scope chain).
- `sx_validate` after every structural edit.
- `list?` returns false on raw JS Arrays — host data must be SX-converted.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/commerce-on-sx.md` inline.
- Short, factual commit messages.
- One feature per iteration. Commit. Log. Push. Next.
Go. Start by reading the plan; find the first unchecked `[ ]`; implement it.

View File

@@ -0,0 +1,115 @@
# content-on-sx loop agent (single agent, phase-ordered)
Role: iterates `plans/content-on-sx.md` forever. **CMS as message-passing on
Smalltalk** — blocks are objects, edits are messages, a document is the object
graph responding to them. Concurrent edits merge via a commutative CRDT so
order doesn't matter. History is the `persist` event stream. External CMS
(Ghost) sync is a thin injected adapter, not core.
```
description: content-on-sx phase loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash-loops/content/plans/content-on-sx.md`.
Isolated worktree, forever, one commit per feature. Push to
`origin/loops/content` after every commit. Never `main`, never `architecture`.
## Restart baseline — check before iterating
1. Read `plans/content-on-sx.md` — Phase queue + Progress log + Blockers.
2. `ls lib/content/` — pick up from the most advanced file.
3. If `lib/content/tests/*.sx` exist, run them via
`bash lib/content/conformance.sh`. Green before new work.
4. Read `lib/smalltalk/smalltalk.sx` public API once — that's your object
model.
5. Check substrate readiness:
- `bash lib/smalltalk/conformance.sh` — must be green
- `lib/persist/persist.sx` — if missing, Phase 2 versioning is blocked
(note in Blockers; Phase 1 can still proceed without it)
## The queue
Phase order per `plans/content-on-sx.md`:
- **Phase 1** — block document model (typed block objects, ordered tree, render)
- **Phase 2** — op log + versioning over `persist` event stream
- **Phase 3** — collaborative merge (CRDT/semilattice op merge)
- **Phase 4** — external sync (Ghost adapter) + federation
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → no-regression gate → commit → tick `[ ]`
→ append dated Progress log line (newest first) → push → stop.
## Ground rules (hard)
- **Scope:** only `lib/content/**` and `plans/content-on-sx.md`. Do NOT
edit `spec/`, `hosts/`, `shared/`, `lib/smalltalk/`, `lib/persist/`,
`lib/stdlib.sx`, or `lib/` root. May **import** from `lib/smalltalk/`,
and once it exists `lib/persist/`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken →
Blockers entry, stop.
- **Determinism = merge commutativity + idempotence.** The CRDT property
isn't optional. Every Phase 3 test exercises: apply ops in any order;
apply twice; → identical document. If you can't prove that, the merge
function is wrong, not the test.
- **Blocks are objects, not records.** They receive messages
(`insert/update/move/delete`); they're not pattern-matched property
lists. If you find yourself doing `case block of {heading, ...}`, you're
fighting the substrate. Smalltalk-on-SX gives you method dispatch — use
it.
- **Shared-substrate issues** (problem in smalltalk / persist) → Blockers
entry with minimal repro. Do NOT patch around it.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit, push to `origin/loops/content`. Never touch `main`
or `architecture`.
- **Commit granularity:** one feature per commit. Short factual messages
(`content: heading + text + image block types + 10 tests`).
- **Plan file:** update Progress log + tick boxes every commit.
## Content-specific gotchas
- **Render is at the boundary.** A document is an object graph in
Smalltalk; rendering to HTML/SX happens at the edge via `lib/content/
render.sx`. The internal model doesn't carry presentation. Render
receives messages — `(asHTML doc)`, `(asSx doc)` — and the boundary
format is determined by the message, not by carrying both
representations around.
- **CRDT is not "last-write-wins."** Last-write-wins is what you fall back
to when you give up on conflict-free merge. Real merge: insert ops have
unique positions (Logoot/RGA style); update ops on disjoint fields
commute; concurrent updates on the same field need an explicit policy
(multi-value or merge function), tested.
- **Versioning is replay.** Any version of the document is the head of an
op stream up to a point. Don't store snapshots as primary state — they're
caches. The op log in `persist` is the source of truth.
- **Ghost sync is an adapter, not a feature.** Treat it like a peripheral.
Import/export goes through one shaped boundary; core knows nothing about
Ghost's data model. If Ghost goes away, core doesn't change.
- **Federated blocks need trust.** A peer-authored block carries provenance
(which actor, which signature). Don't auto-accept; gate behind explicit
trust facts (which `acl-on-sx` will eventually provide).
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr — wrap multiples
in `begin`.
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks
scope chain).
- `sx_validate` after every structural edit.
- `list?` returns false on raw JS Arrays — host data must be SX-converted.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/content-on-sx.md` inline.
- Short, factual commit messages.
- One feature per iteration. Commit. Log. Push. Next.
Go. Start by reading the plan; find the first unchecked `[ ]`; implement it.

View File

@@ -0,0 +1,117 @@
# events-on-sx loop agent (single agent, phase-ordered)
Role: iterates `plans/events-on-sx.md` forever. **Calendar + ticketing as
rule evaluation on Datalog** — events / availability / capacity as facts +
rules; recurrence expands to occurrence facts within a window; bookings are
transactions; reminders/digests are durable `flow`s over an injected
notification transport. Pairs with `commerce-on-sx` for paid tickets.
```
description: events-on-sx phase loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash-loops/events/plans/events-on-sx.md`.
Isolated worktree, forever, one commit per feature. Push to
`origin/loops/events` after every commit. Never `main`, never `architecture`.
## Restart baseline — check before iterating
1. Read `plans/events-on-sx.md` — Phase queue + Progress log + Blockers.
2. `ls lib/events/` — pick up from the most advanced file.
3. If `lib/events/tests/*.sx` exist, run them via
`bash lib/events/conformance.sh`. Green before new work.
4. Read `lib/datalog/datalog.sx` public API once — that's your engine.
5. Check substrate readiness:
- `bash lib/datalog/conformance.sh` — must be green
- `lib/persist/persist.sx` — if missing, Phase 2 transactional booking
is blocked (note in Blockers; Phase 1 can still proceed without it)
- `lib/flow/flow.sx` — if missing, Phase 3 notification flows blocked
## The queue
Phase order per `plans/events-on-sx.md`:
- **Phase 1** — calendar facts + RRULE expansion + availability rules
- **Phase 2** — transactional booking (capacity-safe, persist-backed)
- **Phase 3** — notification delivery flows (reminders, digests, retry)
- **Phase 4** — federation: cross-instance calendars
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → no-regression gate → commit → tick `[ ]`
→ append dated Progress log line (newest first) → push → stop.
## Ground rules (hard)
- **Scope:** only `lib/events/**` and `plans/events-on-sx.md`. Do NOT edit
`spec/`, `hosts/`, `shared/`, `lib/datalog/`, `lib/persist/`, `lib/flow/`,
`lib/stdlib.sx`, or `lib/` root. May **import** from `lib/datalog/`, and
once they exist `lib/persist/` + `lib/flow/`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken →
Blockers entry, stop.
- **Capacity safety is the contract.** Two concurrent bookings on the last
seat must NEVER both succeed. Test the race explicitly. The
capacity-check + append-event must be atomic at the persist boundary; if
persist doesn't expose that primitive, that's a substrate Blockers entry,
not a workaround.
- **Recurrence is bounded.** Never expand an RRULE without a window. An
unbounded RRULE expansion is an infinite computation. Every API entry
that takes an event takes a (start, end) window too.
- **Notifications are at-least-once.** Idempotency keys on every digest /
reminder. A retry must not double-deliver a sent message; the recipient
shouldn't see two "your event starts in 1h" pings.
- **Shared-substrate issues** (problem in datalog / persist / flow) →
Blockers entry with minimal repro. Do NOT patch around it.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit, push to `origin/loops/events`. Never touch `main`
or `architecture`.
- **Commit granularity:** one feature per commit. Short factual messages
(`events: weekly RRULE expansion + 14 tests`).
- **Plan file:** update Progress log + tick boxes every commit.
## Events-specific gotchas
- **RRULE is well-trodden.** RFC 5545 defines the grammar; don't invent a
new recurrence DSL. Implement the subset rose-ash actually needs (daily,
weekly, monthly with byday, until/count) and explicitly defer the rest.
- **Availability is constraint propagation.** Free/busy = forward-chained
Datalog: occurrence facts within window + booking facts + per-attendee
conflict rules. The same query answers "is X free?" and "when is X next
free?" (same rules, different bindings).
- **Capacity ≠ availability.** Availability is per-actor; capacity is
per-event. A room with 50 seats has 50 capacity; the room "available" to
the 51st booker is `false` even though the room exists. Encode capacity
as a separate fact, not as an attribute of availability.
- **Notification delivery is shared with feed/notify.** Don't build a
bespoke email/push transport — inject one and design the interface
generically. When `feed-on-sx` lands its notify path, the two consumers
should share a transport. Flag in Progress log when you build a shape
that's a candidate for `delivery-on-sx` extraction.
- **Paid tickets cross subsystems.** A paid booking calls into
`commerce-on-sx` checkout flow. Don't import commerce here — define the
contract (request, callback shape) and have commerce import you (or both
import a contract module).
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr — wrap multiples
in `begin`.
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks
scope chain).
- `sx_validate` after every structural edit.
- `list?` returns false on raw JS Arrays — host data must be SX-converted.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/events-on-sx.md` inline.
- Short, factual commit messages.
- One feature per iteration. Commit. Log. Push. Next.
Go. Start by reading the plan; find the first unchecked `[ ]`; implement it.

View File

@@ -0,0 +1,128 @@
# identity-on-sx loop agent (single agent, phase-ordered)
Role: iterates `plans/identity-on-sx.md` forever. **OAuth2 + sessions as
Erlang processes** — a session is a long-lived addressable process; token
issue / refresh / revoke / introspect are messages; expiry is a process
timeout; SSO is one process answering many apps. Pairs with `acl-on-sx`:
identity proves "who is X"; acl decides "may X do Y".
```
description: identity-on-sx phase loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash-loops/identity/plans/identity-on-sx.md`.
Isolated worktree, forever, one commit per feature. Push to
`origin/loops/identity` after every commit. Never `main`, never
`architecture`.
## Restart baseline — check before iterating
1. Read `plans/identity-on-sx.md` — Phase queue + Progress log + Blockers.
2. `ls lib/identity/` — pick up from the most advanced file.
3. If `lib/identity/tests/*.sx` exist, run them via
`bash lib/identity/conformance.sh`. Green before new work.
4. Read `lib/erlang/runtime.sx` public API once — that's your process
substrate.
5. Check substrate readiness:
- `bash lib/erlang/conformance.sh` — must be green
- `lib/persist/persist.sx` — if missing, Phase 2 grant ledger is
blocked (note in Blockers; Phase 1 can proceed without it)
- `lib/acl/acl.sx` — if missing, Phase 3 grant-checking is blocked
## The queue
Phase order per `plans/identity-on-sx.md`:
- **Phase 1** — OAuth2 authorization-code + prompt=none flows as message
protocols
- **Phase 2** — token lifecycle (issue/refresh/revoke/introspect), grant
registry, audit ledger
- **Phase 3** — session-as-process with expiry timeouts; SSO fan-out
- **Phase 4** — membership state + cross-app grant verification
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → no-regression gate → commit → tick `[ ]`
→ append dated Progress log line (newest first) → push → stop.
## Ground rules (hard)
- **Scope:** only `lib/identity/**` and `plans/identity-on-sx.md`. Do NOT
edit `spec/`, `hosts/`, `shared/`, `lib/erlang/`, `lib/persist/`,
`lib/acl/`, `lib/stdlib.sx`, or `lib/` root. May **import** from
`lib/erlang/`, and once they exist `lib/persist/` + `lib/acl/`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken →
Blockers entry, stop.
- **Revocation must be real.** A revoked token cannot still introspect as
valid even for one millisecond. Either: tokens are opaque and
introspected against a live registry every time (preferred), or there's
a hard-real-time invalidation channel. Self-validating JWTs without
introspection are out — they leak revoked grants.
- **Authorization is somewhere else.** identity DOES NOT decide
permissions. It proves who. Every "is this allowed?" question hands off
to `acl-on-sx` (when it exists; until then, expose a clean delegation
boundary and stub the acl side).
- **Negative answers are explicit.** "Not authenticated" is a state. "I
don't know who you are" is a 401, not a 500, not a "well I guess so."
Tests cover the negative path as much as the happy path.
- **Audit everything that changes a grant.** Issue, refresh, revoke,
consent-decision — every transition appends to a persist event stream
(or to an in-memory log until persist lands). The ledger is queryable.
- **Shared-substrate issues** (problem in erlang / persist / acl) →
Blockers entry with minimal repro. Do NOT patch around it.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit, push to `origin/loops/identity`. Never touch `main`
or `architecture`.
- **Commit granularity:** one feature per commit. Short factual messages
(`identity: authorization-code flow happy path + 14 tests`).
- **Plan file:** update Progress log + tick boxes every commit.
## Identity-specific gotchas
- **OAuth2 is a state machine, not a function.** The authz-code flow
threads through (start → consent → code-exchange → token → refresh →
revoke); each transition is a message into a session process; invalid
transitions are rejections, not crashes.
- **Silent SSO (`prompt=none`) is a fast-path through the same machine.**
Don't duplicate the implementation. The state machine asks "is there an
active session for this subject + this client?"; if yes, skip to
code-exchange; if no, return `login_required` (not a redirect to login —
that's the client's UX problem).
- **Token storage is the registry, not the token.** Tokens are opaque
binaries; the registry is the source of truth. `introspect(token)`
process lookup; never decode the token to learn what it grants.
- **Session expiry is a timeout, not a cron.** Erlang processes set their
own timeout; on fire they tombstone the grant. Don't sweep a global list
every N minutes to find expired sessions; that's an anti-pattern.
- **Per-app first-party cookies are an HTTP-layer concern, not core.**
Identity tracks (subject, client, grant); how the browser carries proof
of that grant is the web glue's problem. Don't tangle cookie SameSite
policy into the grant machine.
- **OAuth2 is harder than it looks.** Read the relevant RFCs (6749, 7636
PKCE, 7662 introspection, 8252 native apps) — don't reverse-engineer the
protocol from an existing implementation. Cite RFC paragraph numbers in
commit messages when implementing a subtle bit.
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr — wrap multiples
in `begin`.
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks
scope chain).
- `sx_validate` after every structural edit.
- `list?` returns false on raw JS Arrays — host data must be SX-converted.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/identity-on-sx.md` inline.
- Short, factual commit messages.
- One feature per iteration. Commit. Log. Push. Next.
Go. Start by reading the plan; find the first unchecked `[ ]`; implement it.

View File

@@ -19,7 +19,7 @@ injected adapter, not core.
## Status (rolling) ## Status (rolling)
`bash lib/content/conformance.sh`**0/0** (not yet started) `bash lib/content/conformance.sh`**738/738** (Phases 14 COMPLETE + ~34 extensions, hardened: HTML/SX escaping, Markdown render + import/export incl. tables & frontmatter (full round-trip), CvRDT flat + nested-tree + durable replication, tree-aware validation, snapshot cache, doc metadata, plain-text render, nested block trees + deep editing + flatten + relative reorder, doc stats + summary + multi-doc index, table + callout + media blocks, HTML page wrapper + SEO page, doc composition + id-remap, portable data + wire serialization, block query + transforms + find/replace, TOC + anchored headings + outline, normalization)
## Ground rules ## Ground rules
@@ -57,26 +57,356 @@ lib/content/api.sx ── (content/edit) (content/render) (content/history) ─
``` ```
## Phase 1 — Block document model ## Phase 1 — Block document model
- [ ] `block.sx` — typed block objects - [x] `block.sx` — typed block objects
- [ ] `doc.sx` — ordered tree, apply edit op, structural moves - [x] `doc.sx` — ordered tree, apply edit op, structural moves
- [ ] `render.sx` — block tree → HTML/SX - [x] `render.sx` — block tree → HTML/SX
- [ ] `api.sx` + tests + scoreboard + conformance.sh - [x] `api.sx` + tests + scoreboard + conformance.sh
## Phase 2 — Op log + versioning ## Phase 2 — Op log + versioning
- [ ] edit ops as `persist` events; replay to any version - [x] edit ops as `persist` events; replay to any version
- [ ] `(content/history doc)`, diff between versions - [x] `(content/history doc)`, diff between versions
## Phase 3 — Collaborative merge (CRDT) ## Phase 3 — Collaborative merge (CRDT)
- [ ] commutative/idempotent op merge - [x] commutative/idempotent op merge
- [ ] concurrent-edit tests (any order, double-apply → identical) - [x] concurrent-edit tests (any order, double-apply → identical)
## Phase 4 — External sync + federation ## Phase 4 — External sync + federation
- [ ] Ghost/CMS sync via injected adapter (import/export) - [x] Ghost/CMS sync via injected adapter (import/export)
- [ ] federated documents (peer-authored blocks) — trust-gated stub - [x] federated documents (peer-authored blocks) — trust-gated stub
- [ ] tests: round-trip import/export, conflict on concurrent external edit - [x] tests: round-trip import/export, conflict on concurrent external edit
## Extensions (post-roadmap)
- [x] HTML escaping at the render boundary (`String>>htmlEscaped`: & < > ")
- [x] asSx wire string-escaping (`String>>sxEscaped`: \ and " in SX literals)
- [x] Markdown render mode (`asMarkdown:` / `content/render doc "md"`)
- [x] durable CRDT replication (`crdt-store.sx`: ops on persist, replay + converge)
- [x] document validation (`validate.sx`: ids, per-type fields, duplicate ids; tree-aware — descends into sections, tree-wide dup ids, section field check)
- [x] Markdown import adapter (`md-import.sx`: text → blocks, round-trips export; incl. pipe tables + frontmatter → metadata)
- [x] Markdown doc export (`md-doc.sx`: content/markdown-doc, frontmatter from metadata, full round-trip)
- [x] snapshot cache over replay (`snapshot.sx`: cache-not-primary, transparent)
- [x] document metadata (`meta.sx`: title/slug/tags + Ghost title plumbing)
- [x] plain-text render + excerpt (`text.sx`: asText, content/excerpt)
- [x] nested block trees (`section.sx`: CtSection container, recursive render, deep-find)
- [x] document statistics (`stats.sx`: word/char/block counts, reading time)
- [x] table block (`table.sx`: CtTable, renders html/sx/text/md, validated)
- [x] callout block (`callout.sx`: CtCallout note/warning/tip, renders html/sx/text/md, validated)
- [x] media block (`media.sx`: CtMedia video/audio, renders html/sx/text/md, validated)
- [x] list-card summary (`summary.sx`: content/summary — title/excerpt/words/reading/cover)
- [x] multi-doc index (`index.sx`: content/index + index-by-tag + all-tags + has-tag?)
- [x] nested-tree CvRDT (`crdt-tree.sx`: parent-aware, sections merge collaboratively)
- [x] HTML page wrapper (`page.sx`: content/page, escaped title from metadata)
- [x] SEO page (`page-full.sx`: content/page-full, lang + meta description from excerpt)
- [x] document composition (`compose.sx`: concat/prepend/concat-all/wrap-section)
- [x] deep tree editing (`tree-edit.sx`: doc-deep-update/replace/delete/insert-into)
- [x] id remapping / clone (`clone.sx`: content/remap-ids + prefix-ids, collision-free compose)
- [x] block query + TOC (`query.sx`: content/select/select-type/count-type/headings)
- [x] block transforms (`transform.sx`: content/map-blocks/map-type/set-field-on)
- [x] TOC rendering (`toc.sx`: content/toc-markdown + toc-html from headings)
- [x] anchored-heading render (`anchor.sx`: content/html-anchored, functional TOC links)
- [x] document outline (`outline.sx`: content/outline, nested heading tree)
- [x] document flatten (`flatten.sx`: content/flatten, un-nest sections; inverse of wrap-section)
- [x] relative reorder (`move.sx`: content/move-before/after/to-front/to-back by id)
- [x] document normalization (`normalize.sx`: content/normalize, drop empty blocks/sections)
- [x] global find/replace (`find-replace.sx`: content/find-replace across text-bearing blocks)
- [x] portable data serialization (`data.sx`: content/to-data + from-data, round-trips tree)
- [x] wire serialization (`wire.sx`: content/to-wire + from-wire, SX-text on the wire)
## Progress log ## Progress log
(loop fills this in)
- 2026-06-07 — Hardening: regression suite `crdt-blocks` (7 tests) locking that
non-core block types (callout/table/media/section) survive both the flat and
nested-tree CvRDT materialise paths (insert → merge → materialise → render),
the integration the ct-class-for-type fix repaired. Verified flat + tree,
including concurrent mixed-type inserts into a section converging. Suite
738/738.
- 2026-06-07 — Hardening: fixed `ct-class-for-type` (block.sx) to map all block
tags (added section/table/callout/media). Latent bug: `content/from-data` and
CRDT materialise of callout/media blocks failed with "unknown block type" (they
fell through to `mk-block`, which only knew the original 8 types). Now all block
types build uniformly via mk-block; data/wire/CRDT round-trips of callout/media
work. +4 data regression tests; full no-regression gate over the foundational
block.sx change: suite 731/731.
- 2026-06-07 — Extension: nested-tree CvRDT (`crdt-tree.sx`). Extends the flat
CvRDT to a TREE: each element carries a `parent` (containing section id, "" =
root) beside its Logoot pos; merge reuses crdt.sx's pos/register/field joins +
parent (immutable). Materialisation rebuilds the ordered tree (root + per-section
children sorted by pos, recursive). Sections now merge collaboratively; proven
commutative/associative/idempotent — same- and different-parent concurrent
inserts converge, nested sections, LWW, two-replica convergence. Reuses crdt.sx
+ section.sx; flat crdt untouched (34/34). 17 tests; suite 727/727. This was
the flagged "research-grade" gap — done as a clean self-contained layer.
- 2026-06-07 — Extension: multi-document index (`index.sx`). `content/index`
projects a doc list into summary cards (blog index); `content/index-by-tag`
filters by tag (category pages); `content/all-tags` is a deduped tag cloud;
`content/has-tag?`. Composes content/summary + doc metadata. 13 tests; suite
710/710.
- 2026-06-07 — Extension: list-card summary (`summary.sx`). `content/summary`
returns `{:id :title :excerpt :words :reading-minutes :cover}` for index/listing
cards, composing metadata + text + stats + query (`content/cover` = first
image's src). Title falls back to id. 14 tests; suite 697/697.
- 2026-06-07 — Extension: video/audio media block (`media.sx`). `CtMedia` holds
kind (video/audio) + src; answers asHTML (`<video/audio src controls>`,
escaped), asSx, asText (""), asMarkdown: (`[kind](src)`). `mk-media`/`mk-video`/
`mk-audio`/`media?`/`media-kind`. validate.sx gained a `media` case (kind ∈
{video,audio}). Fits the platform's media focus. 15 tests; suite 683/683.
- 2026-06-07 — Extension: relative block reorder (`move.sx`).
`content/move-before` / `content/move-after` move a top-level block to just
before/after another by id; `content/move-to-front` / `move-to-back` too. More
ergonomic than index-based doc-move; no-op on missing ids; immutable. 11 tests;
suite 668/668.
- 2026-06-07 — Extension: callout/admonition block (`callout.sx`). `CtCallout`
holds kind (note/warning/tip) + text; answers asHTML (`<aside class="callout
callout-KIND">`, escaped), asSx, asText, asMarkdown: (`> **kind:** text`).
Self-contained; `mk-callout`/`callout?`/`callout-kind`. validate.sx gained a
`callout` field case. 12 tests; suite 657/657.
- 2026-06-07 — Extension: document flatten (`flatten.sx`). `content/flatten`
un-nests a sectioned doc into a flat block sequence (each section replaced
inline by its recursively-flattened children, wrapper dropped) — the inverse of
content/wrap-section, for flat export targets. Inline tree handling; immutable.
10 tests; suite 645/645.
- 2026-06-07 — Extension: nested document outline (`outline.sx`).
`content/outline` builds a hierarchical heading tree from content/headings —
each node `{:id :text :level :children}`, headings nesting under the nearest
lower-level heading (recursive forest build). The structured companion to the
flat TOC for nested nav. 14 tests; suite 635/635.
- 2026-06-07 — Extension: anchored-heading render (`anchor.sx`).
`content/html-anchored` renders like asHTML but headings carry `id="<block-id>"`
(tree-wide, sections recurse, text escaped), so the TOC's `#id` links resolve —
completing the TOC feature end-to-end. A separate render; plain asHTML
unchanged. 6 tests; suite 621/621.
- 2026-06-07 — Extension: global find/replace (`find-replace.sx`).
`content/find-replace` replaces every occurrence of a substring in the text
field of text/heading/code/quote blocks tree-wide (via the transform layer) —
rename a term throughout a doc. Leaves non-text fields (image alt/src) alone;
immutable, case-sensitive. 10 tests; suite 615/615.
- 2026-06-07 — Extension: document normalization (`normalize.sx`).
`content/normalize` drops empty text blocks and empty sections tree-wide;
sections are normalised first so one emptied by the pass is itself removed.
For tidying imported/edited docs; non-text empties (dividers, blank-alt images)
preserved. Inline tree handling; immutable. 11 tests; suite 605/605.
- 2026-06-07 — Extension: table-of-contents rendering (`toc.sx`).
`content/toc-markdown` produces a Markdown bullet list indented by heading
level with `[text](#id)` links; `content/toc-html` produces a `<ul>` of escaped
anchor links (`#id`). Built from `content/headings`; the blog page's TOC
artifact. 8 tests; suite 594/594.
- 2026-06-07 — Extension: tree-wide block transforms (`transform.sx`). The write
counterpart to query: `content/map-blocks` (predicate) / `content/map-type` /
`content/set-field-on` apply a function to every matching block across the tree
(sections rebuilt), for bulk edits (cdn src rewrites, heading-level bumps, text
sanitisation). Inline tree rebuild (no section.sx dep); immutable. 12 tests;
suite 586/586.
- 2026-06-07 — Extension: block query + TOC (`query.sx`). `content/select`
(predicate) / `content/select-type` / `content/count-type` / `content/select-ids`
collect blocks across the whole tree (sections recurse); `content/headings`
derives a table of contents (`{:id :level :text}` per heading, document order).
Inline tree detection (no section.sx dep). 13 tests; suite 574/574.
- 2026-06-07 — Extension: id remapping / clone (`clone.sx`).
`content/remap-ids` deep-rewrites every block id across the tree (sections
recurse) via a function; `content/prefix-ids` prefixes them. Enables
collision-free composition (prefix each doc before concat → validates clean,
where the unprefixed concat has duplicate ids). Content unchanged, only ids;
immutable. 10 tests; suite 561/561.
- 2026-06-07 — Extension: deep tree editing (`tree-edit.sx`). `doc-deep-update`
/ `doc-deep-replace` / `doc-deep-delete` / `doc-deep-insert-into` mutate blocks
anywhere in the nested tree (descending into CtSection children), completing
tree mutation to match the deep-find read path; all immutable. 17 tests; suite
551/551.
- 2026-06-07 — Extension: on-the-wire serialization (`wire.sx`).
`content/to-wire` serialises a document to a transmittable SX-text string (data
form + SX serializer); `content/from-wire` parses it back into a live document.
The whole-document format for persistence / HTTP / federation (distinct from
the per-op persist log); round-trips nested trees + tables; reads externally
authored wire strings. 11 tests; suite 534/534.
- 2026-06-07 — Extension: portable data serialization (`data.sx`).
`content/to-data` converts a document to plain SX data
(`{:id :title :slug :tags :blocks [{:id :type :fields}]}`, sections recursing);
`content/from-data` reconstructs real block objects (section/table handled
specially, others generically via mk-block). Round-trips the full tree +
metadata (render-equal), decoupling storage/transport from the Smalltalk
instance shape. 21 tests; suite 523/523.
- 2026-06-07 — Extension: document composition (`compose.sx`). `content/concat`
/ `content/prepend` / `content/concat-all` combine documents (keeping the
first's id + metadata, concatenating blocks, immutable); `content/wrap-section`
collapses a doc's blocks into a single nested section. For assembling pages
from header/body/footer parts and templates. 17 tests; suite 502/502.
- 2026-06-07 — Extension: SEO-complete page (`page-full.sx`). `content/page-full`
extends content/page with `<html lang="en">` and a `<meta name="description">`
drawn from the document excerpt (plain text, escaped, 160 chars), composing the
page/metadata/text layers into the SEO-ready artifact. 4 tests; suite 485/485.
- 2026-06-07 — Extension: Markdown document export (`md-doc.sx`).
`content/markdown-doc` emits a `---` frontmatter block from metadata
(title/slug/tags, only present fields) ahead of the Markdown body, or plain
asMarkdown when there's no metadata. Completes the metadata round-trip:
`md/import ∘ content/markdown-doc` preserves title/slug/tags + blocks. 12
tests; suite 481/481.
- 2026-06-07 — Extension: Markdown frontmatter. `md/import` parses a leading
`---` / `key: value` / `---` block into document metadata (title, slug,
comma-separated tags via `doc-with-meta`) before parsing the body; a `---`
elsewhere stays a divider. Ties the Markdown importer to the metadata layer the
way real blog posts work. +9 tests; suite 469/469.
- 2026-06-07 — Extension: Markdown table import. `md-import.sx` now recognizes a
`| … |` header row followed by a `| --- |` separator and parses a `CtTable`
(cells trimmed, mixed with other blocks via blank-line separation), completing
the Markdown table round-trip (import∘export == identity). +5 tests; suite
460/460.
- 2026-06-07 — Extension: HTML page wrapper (`page.sx`). `content/page` composes
metadata + render into a minimal valid HTML5 document — escaped `<title>` from
doc metadata (falling back to id) and the rendered blocks as the body.
`content/page-title`. The shippable artifact the blog serves. 7 tests; suite
455/455.
- 2026-06-07 — Extension: table block (`table.sx`). `CtTable` holds headers +
rows (string lists); answers asHTML (escaped `<table>`), asSx, asText, and
asMarkdown: (pipe table with dashed separator row) by folding rows×cells via
nested `inject:into:`. Self-contained (no edits to block.sx/render.sx);
`mk-table`, `table?`, `table-headers/rows`. validate.sx gained a `table` field
case (headers/rows must be lists). 15 tests; suite 448/448.
- 2026-06-07 — Extension: document statistics (`stats.sx`). `content/stats`
returns `{:words :chars :blocks :reading-minutes}`; word/char counts derive
from the tree-accurate `asText` projection, block count from an inline tree
walk (no section.sx dep), reading time at 200 wpm rounded up. Counts descend
into nested sections. 17 tests; suite 433/433.
- 2026-06-07 — Refinement: tree-aware validation. `validate.sx` now flattens the
whole block tree (descending into `CtSection` children, guarding malformed
non-list children) so field checks and duplicate-id detection cover nested
blocks and span section boundaries; added a `section` field-type case. Inline
tree detection (class + st-iv-get) keeps it free of a section.sx dependency.
+6 tests; suite 416/416.
- 2026-06-07 — Extension: nested block trees (`section.sx`). `CtSection` is a
block whose `children` ivar is a list of blocks (incl. nested sections →
arbitrary depth), turning the flat document into the ordered TREE from the
architecture sketch. Self-contained: it answers asHTML/asSx/asText/asMarkdown:
by folding children's renderings (pure polymorphic recursion — no changes to
block.sx/render.sx). `mk-section`, `section-children`, `section-append` (cow),
and tree traversal `doc-deep-find` / `doc-tree-ids` / `doc-tree-count` that
descend into sections. 25 tests; suite 410/410.
- 2026-06-07 — Extension: plain-text render + excerpts (`text.sx`). Fourth
boundary format via polymorphic `asText` (heading/text/code/quote→text,
image→alt, embed/divider→"", list→", "-joined); the document joins non-empty
child texts with a space. `content/render doc "text"`, `content/text`,
`content/excerpt doc n` (first n chars + "…" if truncated). For previews,
meta-descriptions, search indexing. 20 tests; suite 385/385.
- 2026-06-07 — Extension: document metadata (`meta.sx`). CtDoc gained optional
title/slug/tags ivars (declared in doc.sx, default nil/empty, no effect on
block ops). Reads via message dispatch; copy-on-write setters
(`doc-with-title/slug/tags`, `doc-add-tag`, `doc-with-meta`, `doc-new-meta`)
and `content/*` aliases; `doc-meta` returns the metadata dict. Ghost adapter
now carries `:title` through import/export/round-trip. 27 tests; suite 365/365.
- 2026-06-07 — Extension: snapshot cache over op-log replay (`snapshot.sx`).
Snapshots are a cache, never primary state — the log stays the source of truth.
`content/snapshot!` stores a materialised head at a seq in the persist KV;
`content/head-cached` / `content/at-cached` start from the nearest snapshot and
replay only the tail, returning a document IDENTICAL to a full replay (tests
assert transparency before/after snapshot, across versions, and after
drop-snapshot fallback). `content/has-snapshot?` / `snapshot-seq` /
`drop-snapshot!`. 20 tests; suite 338/338.
- 2026-06-07 — Extension: Markdown import adapter (`md-import.sx`), inverse of
asMarkdown. Line-based parser: ATX headings, fenced code (```lang), blockquotes,
unordered/ordered lists (grouping consecutive items), thematic breaks,
paragraphs (consecutive plain lines joined with a space). Sequential ids
b0,b1…. `md/import` / `content/from-markdown` / `markdown-adapter` (import +
asMarkdown export). Round-trips canonical Markdown (import∘export == identity);
imported docs pass validation. 24 tests; suite 318/318.
- 2026-06-07 — Extension: document validation (`validate.sx`). `content/validate`
returns issue dicts `{:id :kind :detail}` (empty = valid); `content/valid?`
and `content/issue-kinds` convenience. Checks block id (non-empty string),
per-type required fields/types (heading level number, image src/alt strings,
list ordered boolean + items list, etc.), unknown block types, and
document-level duplicate ids. Guards imports/edits/federated input. 17 tests;
suite 294/294.
- 2026-06-07 — Extension: durable CRDT replication (`crdt-store.sx`), uniting
Phase 2 (persist) + Phase 3 (CvRDT). Each replica appends its CRDT ops to its
own stream (`crdt:<doc>:<replica>`); `crdt/replay` folds one log into a state,
`crdt/converge` merges every replica's replayed state, `crdt/document` /
`crdt/order` materialise. Converged result is identical regardless of replica
order or duplicate delivery (join + idempotent apply) → offline-capable,
eventually-consistent editing. 14 tests; suite 277/277.
- 2026-06-07 — Extension: Markdown render mode (`markdown.sx`). Third boundary
format alongside asHTML/asSx via the same polymorphic dispatch; blocks answer
`asMarkdown: nl` (boundary supplies the newline — this Smalltalk dialect has
no Character newline ctor). `content/render doc "md"`/`"markdown"`/`:md`,
`content/markdown`, `asMarkdown`. headings (`#`×level), fenced code, `> ` quote,
`![alt](src)`, `- `/`1. ` lists, `---`; doc joins blocks with a blank line. No
MD escaping yet. 20 tests; suite 263/263.
- 2026-06-07 — Extension: asSx wire string-escaping. Added `String>>sxEscaped`
(escapes `\`→`\\` then `"``\"`) and routed every `asSx` text/attr/list-item
through it, so the SX wire format stays valid when content contains quotes or
backslashes. +5 render tests (expected strings built from `q`/`bs` helpers to
avoid escaping miscounts). Suite 243/243.
- 2026-06-07 — Extension: HTML escaping at the render boundary. Added
`String>>htmlEscaped` (recursive char walk escaping & < > ", order-safe so &
isn't double-escaped) and routed every `asHTML` text/attr through it — heading,
text, code body + language, quote, image src/alt, embed url, list items.
Render stays fully polymorphic in Smalltalk; escaping lives at the boundary.
+8 render tests (incl. `<script>` payloads, attr breakout, ampersand-once).
asSx wire-escaping deferred to next. Suite 238/238.
- 2026-06-07 — Phase 4 `fed.sx` (**Phase 4 COMPLETE — roadmap done**):
trust-gated federation. Peer ops carry provenance (`:author`, `:sig` stub);
none are auto-accepted. The trust gate is a pluggable predicate (acl-on-sx
hook) with a trusted-actor-list convenience stub. `content/merge-peer[-with]`
applies only accepted ops through the CvRDT and quarantines the rest
(`{:state :accepted :rejected}`). Concurrent local/external edits reconcile
deterministically: same-field LWW by (ts,actor), commutative, idempotent;
untrusted ops never touch state. 20 tests; suite 230/230.
- 2026-06-07 — Phase 4 `sync.sx` (cb1): external CMS sync via an injected
adapter. Core defines the shape — `{:import :export}` — and delegates;
`content/import` / `content/export` / `content/round-trip` know nothing about
Ghost. A Ghost-flavoured adapter confines all format translation (post
`:sections` ↔ content blocks, all 8 kinds). Swapping in a stub `raw-adapter`
works identically. Round-trip (export∘import and import∘export) preserves ids,
types, fields, order. 14 tests; suite 210/210. Next: trust-gated federation +
concurrent-external-edit conflict (via CRDT).
- 2026-06-07 — Phase 3 `crdt.sx` (**Phase 3 complete**): collaborative merge as
a state-based CvRDT. Merge is a join (lub) on a semilattice → commutative,
associative, idempotent by construction. Ordering = unique dense Logoot
position keys (cell = (digit actor), lexicographic); presence = OR-tombstones
(remove-wins); each field = an LWW-Register keyed by logical (ts, actor). Every
op contributes a PARTIAL element and per-id state is their join, so
update-/delete-before-insert are not lost. `crdt-materialize` bridges back to a
Phase-1 `CtDoc` (sort live elements by pos → blocks). Tests prove: ops in any
order converge, double-apply is a no-op, merge commutes/associates/is
idempotent, concurrent inserts order deterministically, same-field LWW by
(ts,actor), disjoint fields both survive, two divergent replicas converge both
ways. 34 tests; suite 196/196.
- 2026-06-07 — Phase 2 `store.sx` (**Phase 2 complete**): op log + versioning
over the persist event stream. `content/commit!` appends an edit op as a
persist event to the doc's stream (`content:<id>`); the log is the source of
truth. `content/head` / `content/at b id seq` replay the op stream to the
latest / any version (materialised doc is a cache, never primary state).
`content/history` returns per-version metadata; `content/diff` /
`content/diff-versions` report added/removed/changed block ids. Backend is
injected via `(persist/open)` — content knows nothing about which backend.
Minimal persist load (event/backend/log/kv/api). 29 tests; suite 162/162.
- 2026-06-07 — Phase 1 `api.sx` (**Phase 1 complete**): `content/*` facade over
block + doc + render. `content/bootstrap!` registers the hierarchy;
`content/edit` applies one op or an op stream; `content/render` picks the
boundary format ("html"/"sx" or keyword). Re-exports `content/new`,
`content/append`, `content/insert|update|move|delete`, `content/find`, etc.
`content/op?` distinguishes a single op from a list/block. 26 tests; suite
133/133. content/history deferred to Phase 2 (needs the persist op log).
- 2026-06-07 — Phase 1 `render.sx`: render boundary as polymorphic message
dispatch. Every block and `CtDoc` answers `asHTML` / `asSx`; the document
folds children via Smalltalk `inject:into:` (works on raw SX lists), so
`(asHTML doc)` / `(asSx doc)` are pure sends with zero type-switching in SX.
Lists/headings render in Smalltalk source. No HTML escaping yet (noted in
render.sx — boundary concern before untrusted content). 29 tests; suite
107/107.
- 2026-06-06 — Phase 1 `doc.sx`: ordered block document (`CtDoc`) as a
Smalltalk object holding an ordered block sequence. Edit ops are data dicts
(`insert`/`update`/`move`/`delete`) with `op-*` constructors; `doc-apply` /
`doc-apply-all` interpret an op stream, each returning a NEW document (input
never mutated → replay-safe). Structural moves, insert-after/at, find/index,
immutability all tested. 40 tests; suite 78/78.
- 2026-06-06 — Phase 1 `block.sx`: typed block objects as Smalltalk instances
(`CtBlock` hierarchy: text/heading/code/quote/image/embed/divider/list).
Type tag + accessors are message sends (polymorphic dispatch); fields are
immutable copy-on-write via functional `st-iv-set!` (history-safe). Added
`mk-*` constructors, `block?` predicate, `lib/content/conformance.sh` +
scoreboard. 38/38.
## Blockers ## Blockers
(loop fills this in)
- Smalltalk-only load chain (tokenizer/parser/runtime/eval) does **not** load
`lib/r7rs.sx`/`spec/stdlib.sx`, so r7rs aliases (`car`/`cdr`/`null?`) are
absent. Use base SX primitives (`first`/`rest`/`(= (len x) 0)`) in
`lib/content/**`. Not a substrate bug — just the load surface.