From 6a246039b5c91569a05df4abf5b77552914c76ad Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 6 Jun 2026 23:51:46 +0000 Subject: [PATCH] content: typed block objects on smalltalk + 38 tests Co-Authored-By: Claude Opus 4.8 (1M context) --- lib/content/block.sx | 163 ++++++++++++++++++++++++++++++++++++ lib/content/conformance.sh | 114 +++++++++++++++++++++++++ lib/content/scoreboard.json | 8 ++ lib/content/scoreboard.md | 8 ++ lib/content/tests/block.sx | 75 +++++++++++++++++ plans/content-on-sx.md | 18 +++- 6 files changed, 382 insertions(+), 4 deletions(-) create mode 100644 lib/content/block.sx create mode 100755 lib/content/conformance.sh create mode 100644 lib/content/scoreboard.json create mode 100644 lib/content/scoreboard.md create mode 100644 lib/content/tests/block.sx diff --git a/lib/content/block.sx b/lib/content/block.sx new file mode 100644 index 00000000..d4aabf06 --- /dev/null +++ b/lib/content/block.sx @@ -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")))) diff --git a/lib/content/conformance.sh b/lib/content/conformance.sh new file mode 100755 index 00000000..87c5a412 --- /dev/null +++ b/lib/content/conformance.sh @@ -0,0 +1,114 @@ +#!/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) + +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/content/block.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 ] diff --git a/lib/content/scoreboard.json b/lib/content/scoreboard.json new file mode 100644 index 00000000..6ebb3777 --- /dev/null +++ b/lib/content/scoreboard.json @@ -0,0 +1,8 @@ +{ + "suites": { + "block": {"pass": 38, "fail": 0} + }, + "total_pass": 38, + "total_fail": 0, + "total": 38 +} diff --git a/lib/content/scoreboard.md b/lib/content/scoreboard.md new file mode 100644 index 00000000..13b4bd16 --- /dev/null +++ b/lib/content/scoreboard.md @@ -0,0 +1,8 @@ +# content-on-sx Conformance Scoreboard + +_Generated by `lib/content/conformance.sh`_ + +| Suite | Pass | Fail | Total | +|-------|-----:|-----:|------:| +| block | 38 | 0 | 38 | +| **Total** | **38** | **0** | **38** | diff --git a/lib/content/tests/block.sx b/lib/content/tests/block.sx new file mode 100644 index 00000000..c6fc49c8 --- /dev/null +++ b/lib/content/tests/block.sx @@ -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") diff --git a/plans/content-on-sx.md b/plans/content-on-sx.md index 03f606fa..eab4a1f5 100644 --- a/plans/content-on-sx.md +++ b/plans/content-on-sx.md @@ -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` → **38/38** (Phase 1: typed blocks) ## Ground rules @@ -57,7 +57,7 @@ lib/content/api.sx ── (content/edit) (content/render) (content/history) ─ ``` ## Phase 1 — Block document model -- [ ] `block.sx` — typed block objects +- [x] `block.sx` — typed block objects - [ ] `doc.sx` — ordered tree, apply edit op, structural moves - [ ] `render.sx` — block tree → HTML/SX - [ ] `api.sx` + tests + scoreboard + conformance.sh @@ -76,7 +76,17 @@ lib/content/api.sx ── (content/edit) (content/render) (content/history) ─ - [ ] tests: round-trip import/export, conflict on concurrent external edit ## Progress log -(loop fills this in) + +- 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.