Compare commits

..

33 Commits

Author SHA1 Message Date
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
62 changed files with 6483 additions and 14 deletions

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)

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

@@ -0,0 +1,163 @@
;; 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)
(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")
(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"))))

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))))))

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

@@ -0,0 +1,145 @@
#!/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 clone query stats table data wire validate store snapshot crdt 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/clone.sx")
(load "lib/content/query.sx")
(load "lib/content/stats.sx")
(load "lib/content/table.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-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))))

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)))

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})

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)

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,34 @@
{
"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},
"clone": {"pass": 10, "fail": 0},
"query": {"pass": 13, "fail": 0},
"stats": {"pass": 17, "fail": 0},
"table": {"pass": 15, "fail": 0},
"data": {"pass": 21, "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-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": 574,
"total_fail": 0,
"total": 574
}

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

@@ -0,0 +1,34 @@
# 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 |
| clone | 10 | 0 | 10 |
| query | 13 | 0 | 13 |
| stats | 17 | 0 | 17 |
| table | 15 | 0 | 15 |
| data | 21 | 0 | 21 |
| wire | 11 | 0 | 11 |
| validate | 23 | 0 | 23 |
| store | 29 | 0 | 29 |
| snapshot | 20 | 0 | 20 |
| crdt | 34 | 0 | 34 |
| crdt-store | 14 | 0 | 14 |
| sync | 14 | 0 | 14 |
| md-import | 38 | 0 | 38 |
| md-doc | 12 | 0 | 12 |
| fed | 20 | 0 | 20 |
| **Total** | **574** | **0** | **574** |

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))))

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))))

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 — 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,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)

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)

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

@@ -0,0 +1,93 @@
;; 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!)
;; ── 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"))
;; ── 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,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)

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")

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))

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")

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) "…")))))

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))))

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

@@ -0,0 +1,195 @@
;; 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")))
(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)
`bash lib/content/conformance.sh`**0/0** (not yet started)
`bash lib/content/conformance.sh`**574/574** (Phases 14 COMPLETE + extensions: HTML/SX escaping, Markdown render + import/export incl. tables & frontmatter (full round-trip), CRDT replication, tree-aware validation, snapshot cache, doc metadata, plain-text render, nested block trees + deep tree editing, doc stats, table block, HTML page wrapper + SEO page, doc composition + id-remap, portable data + wire serialization, block query + TOC)
## Ground rules
@@ -57,26 +57,261 @@ lib/content/api.sx ── (content/edit) (content/render) (content/history) ─
```
## Phase 1 — Block document model
- [ ] `block.sx` — typed block objects
- [ ] `doc.sx` — ordered tree, apply edit op, structural moves
- [ ] `render.sx` — block tree → HTML/SX
- [ ] `api.sx` + tests + scoreboard + conformance.sh
- [x] `block.sx` — typed block objects
- [x] `doc.sx` — ordered tree, apply edit op, structural moves
- [x] `render.sx` — block tree → HTML/SX
- [x] `api.sx` + tests + scoreboard + conformance.sh
## Phase 2 — Op log + versioning
- [ ] edit ops as `persist` events; replay to any version
- [ ] `(content/history doc)`, diff between versions
- [x] edit ops as `persist` events; replay to any version
- [x] `(content/history doc)`, diff between versions
## Phase 3 — Collaborative merge (CRDT)
- [ ] commutative/idempotent op merge
- [ ] concurrent-edit tests (any order, double-apply → identical)
- [x] commutative/idempotent op merge
- [x] concurrent-edit tests (any order, double-apply → identical)
## Phase 4 — External sync + federation
- [ ] Ghost/CMS sync via injected adapter (import/export)
- [ ] federated documents (peer-authored blocks) — trust-gated stub
- [ ] tests: round-trip import/export, conflict on concurrent external edit
- [x] Ghost/CMS sync via injected adapter (import/export)
- [x] federated documents (peer-authored blocks) — trust-gated stub
- [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] 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] 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
(loop fills this in)
- 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
(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.