commerce: end-to-end composition integration suite (19 tests) — hardening

tests/integration.sx — one narrative across every module: catalog -> stock
check -> quote (promo+stack+tax) -> attribution -> order flow -> payment
envelope -> settle -> recon -> refund flow -> ledger mismatch, asserting the
seams tie together with consistent numbers. Proves the three-substrate
composition (minikanren pricing + flow lifecycle + persist ledger) end to end.
Total 297/297 across 18 suites.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>

hosts/ocaml/bin/sx_server.ml

@@ -855,164 +855,6 @@ let setup_evaluator_bridge env =
       done;
       Nil
     | _ -> raise (Eval_error "http-listen: (port handler)"));
-
-  (* fed-sx Milestone 1 client direction (Phase J). NATIVE ONLY —
-     Unix sockets + DNS; absent from the WASM kernel. HTTP/1.1
-     request: TCP connect, write request line + headers + body,
-     read status + headers + body, return {:status :headers :body}.
-     URL must be http://...; HTTPS is a later phase (needs TLS).
-     Body read: Content-Length first, else read to EOF (we send
-     Connection: close). Transfer-Encoding: chunked is rejected —
-     fed-sx Phase 8 wires this for inter-server POSTs which will
-     all carry Content-Length. *)
-  Sx_primitives.register "http-request" (fun args ->
-    let strip_cr s =
-      let n = String.length s in
-      if n > 0 && s.[n - 1] = '\r' then String.sub s 0 (n - 1) else s
-    in
-    match args with
-    | [String meth; String url; headers_v; body_v] ->
-      let body = match body_v with
-        | String s -> s
-        | Nil -> ""
-        | v -> Sx_types.value_to_string v in
-      let prefix = "http://" in
-      let plen = String.length prefix in
-      let ulen = String.length url in
-      if ulen < plen || String.sub url 0 plen <> prefix
-      then raise (Eval_error "http-request: URL must start with http://");
-      let rest = String.sub url plen (ulen - plen) in
-      let host_port, path =
-        match String.index_opt rest '/' with
-        | Some i ->
-          String.sub rest 0 i,
-          String.sub rest i (String.length rest - i)
-        | None -> rest, "/" in
-      if host_port = "" then
-        raise (Eval_error "http-request: missing host");
-      let host, port =
-        match String.index_opt host_port ':' with
-        | Some i ->
-          let h = String.sub host_port 0 i in
-          let ps = String.sub host_port (i + 1)
-                     (String.length host_port - i - 1) in
-          (h,
-           (try int_of_string ps with _ ->
-              raise (Eval_error "http-request: bad port")))
-        | None -> host_port, 80 in
-      let addr =
-        (try (Unix.gethostbyname host).h_addr_list.(0)
-         with Not_found ->
-           raise (Eval_error ("http-request: dns: " ^ host))) in
-      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
-      let cleanup () = try Unix.close sock with _ -> () in
-      let result =
-        (try
-          (try Unix.connect sock (Unix.ADDR_INET (addr, port))
-           with Unix.Unix_error (e, _, _) ->
-             raise (Eval_error
-                      ("http-request: connect: " ^ Unix.error_message e)));
-          let oc = Unix.out_channel_of_descr sock in
-          let ic = Unix.in_channel_of_descr sock in
-          let buf = Buffer.create 256 in
-          Buffer.add_string buf
-            (Printf.sprintf "%s %s HTTP/1.1\r\n" meth path);
-          let host_hdr_sent = ref false in
-          let clen_sent = ref false in
-          let conn_sent = ref false in
-          (match headers_v with
-           | Dict h ->
-             Hashtbl.iter (fun k v ->
-               let kl = String.lowercase_ascii k in
-               if kl = "host" then host_hdr_sent := true;
-               if kl = "content-length" then clen_sent := true;
-               if kl = "connection" then conn_sent := true;
-               let vs = match v with
-                 | String s -> s
-                 | x -> Sx_types.value_to_string x in
-               Buffer.add_string buf
-                 (Printf.sprintf "%s: %s\r\n" k vs)) h
-           | Nil -> ()
-           | _ -> raise (Eval_error "http-request: headers must be dict"));
-          if not !host_hdr_sent then
-            Buffer.add_string buf
-              (Printf.sprintf "Host: %s\r\n" host_port);
-          if not !clen_sent then
-            Buffer.add_string buf
-              (Printf.sprintf "Content-Length: %d\r\n"
-                 (String.length body));
-          if not !conn_sent then
-            Buffer.add_string buf "Connection: close\r\n";
-          Buffer.add_string buf "\r\n";
-          Buffer.add_string buf body;
-          output_string oc (Buffer.contents buf);
-          flush oc;
-          let sl =
-            (try strip_cr (input_line ic)
-             with End_of_file ->
-               raise (Eval_error
-                        "http-request: connection closed before status")) in
-          let status =
-            match String.split_on_char ' ' sl with
-            | _ver :: code :: _ ->
-              (try int_of_string code with _ ->
-                 raise (Eval_error "http-request: bad status code"))
-            | _ -> raise (Eval_error "http-request: bad status line") in
-          let rhdrs = Sx_types.make_dict () in
-          let clen = ref (-1) in
-          let chunked = ref false in
-          let rec rdh () =
-            let h =
-              (try strip_cr (input_line ic)
-               with End_of_file -> "") in
-            if h = "" then ()
-            else begin
-              (match String.index_opt h ':' with
-               | Some i ->
-                 let name =
-                   String.lowercase_ascii
-                     (String.trim (String.sub h 0 i)) in
-                 let value =
-                   String.trim
-                     (String.sub h (i + 1)
-                        (String.length h - i - 1)) in
-                 Hashtbl.replace rhdrs name (String value);
-                 if name = "content-length" then
-                   (try clen := int_of_string value with _ -> ())
-                 else if name = "transfer-encoding" &&
-                         String.lowercase_ascii value = "chunked"
-                 then chunked := true
-               | None -> ());
-              rdh ()
-            end in
-          rdh ();
-          if !chunked then
-            raise (Eval_error
-                     "http-request: chunked transfer-encoding not supported");
-          let rbody =
-            if !clen >= 0 then begin
-              let b = Bytes.create !clen in
-              really_input ic b 0 !clen;
-              Bytes.unsafe_to_string b
-            end else begin
-              let b = Buffer.create 256 in
-              (try
-                 while true do
-                   Buffer.add_channel b ic 4096
-                 done; assert false
-               with End_of_file -> ());
-              Buffer.contents b
-            end in
-          let resp = Sx_types.make_dict () in
-          Hashtbl.replace resp "status" (Integer status);
-          Hashtbl.replace resp "headers" (Dict rhdrs);
-          Hashtbl.replace resp "body" (String rbody);
-          Dict resp
-        with e -> cleanup (); raise e) in
-      cleanup ();
-      result
-    | _ -> raise (Eval_error "http-request: (method url headers body)"));
-
   bind "trampoline" (fun args ->
     match args with
     | [v] ->

hosts/ocaml/bin/test_http_client.sh

@@ -1,80 +0,0 @@
-#!/usr/bin/env bash
-# Phase J test — native-only http-request client primitive.
-# Reuses Phase H's http-listen to spin up an echo server, then drives
-# a separate sx_server via the epoch protocol to issue http-request
-# calls and assert response shape + headers + body.
-set -u
-cd "$(dirname "$0")/.."
-
-SRV=_build/default/bin/sx_server.exe
-PORT=${HTTP_CLIENT_TEST_PORT:-8921}
-PASS=0
-FAIL=0
-ok()  { echo "  PASS: $1"; PASS=$((PASS+1)); }
-bad() { echo "  FAIL: $1 — $2"; FAIL=$((FAIL+1)); }
-
-if [ ! -x "$SRV" ]; then
-  echo "build sx_server.exe first (dune build bin/sx_server.exe)"; exit 1
-fi
-
-# /echo echoes method/path/query/body and reflects request X-Custom
-# back as response X-Got; /missing-test → 404.
-H='(begin (define (h req) (if (= (get req "path") "/echo") {:status 200 :headers {"X-Echo" (get req "method") "X-Got" (get (get req "headers") "x-custom")} :body (str "M=" (get req "method") " P=" (get req "path") " Q=" (get req "query") " B=" (get req "body"))} (if (= (get req "path") "/missing-test") {:status 404 :body "nope"} {:status 500 :body "err"}))) (http-listen '"$PORT"' h))'
-ESC=${H//\"/\\\"}
-
-{ printf '(epoch 1)\n(eval "%s")\n' "$ESC"; sleep 60; } | "$SRV" >/tmp/test_http_client_srv.out 2>&1 &
-SVPID=$!
-trap 'kill $SVPID 2>/dev/null; wait 2>/dev/null' EXIT
-
-up=0
-for _ in $(seq 1 50); do
-  curl -s -o /dev/null "http://127.0.0.1:$PORT/echo" 2>/dev/null && { up=1; break; }
-  sleep 0.2
-done
-[ "$up" = 1 ] || { echo "  FAIL: server did not start"; cat /tmp/test_http_client_srv.out; exit 1; }
-
-emit() {
-  # $1 = epoch num, $2 = raw SX form. Wraps in (eval "...") with quotes escaped.
-  local esc=${2//\"/\\\"}
-  printf '(epoch %s)\n(eval "%s")\n' "$1" "$esc"
-}
-
-DRV_OUT=/tmp/test_http_client_drv.out
-{
-  emit 1 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo?x=1" {} ""))) (str "S=" (get r "status") " E=" (get (get r "headers") "x-echo") " B=" (get r "body")))'
-  emit 2 '(let ((r (http-request "POST" "http://127.0.0.1:'"$PORT"'/echo" {} "hello"))) (str "S=" (get r "status") " B=" (get r "body")))'
-  emit 3 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/missing-test" {} ""))) (str "S=" (get r "status") " B=" (get r "body")))'
-  emit 4 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {"X-Custom" "myval"} ""))) (get (get r "headers") "x-got"))'
-  emit 5 '(http-request "GET" "ftp://nope" {} "")'
-  emit 6 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {} ""))) (get r "status"))'
-} | "$SRV" >"$DRV_OUT" 2>&1
-
-# eval results come back as (ok-len N L)\n<body>\n — grep the body content.
-grep -q '^"S=200 E=GET B=M=GET P=/echo Q=x=1 B="$' "$DRV_OUT" \
-  && ok "GET status + echo header + body" \
-  || bad "GET" "$(grep -A1 '^(ok-len 1 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"S=200 B=M=POST P=/echo Q= B=hello"$' "$DRV_OUT" \
-  && ok "POST body roundtrip" \
-  || bad "POST" "$(grep -A1 '^(ok-len 2 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"S=404 B=nope"$' "$DRV_OUT" \
-  && ok "404 status + body" \
-  || bad "404" "$(grep -A1 '^(ok-len 3 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"myval"$' "$DRV_OUT" \
-  && ok "custom request header reaches server" \
-  || bad "custom-header" "$(grep -A1 '^(ok-len 4 ' "$DRV_OUT" | tail -1)"
-
-R5=$(grep '^(error 5 ' "$DRV_OUT" | head -1)
-echo "$R5" | grep -q 'URL must start with http' \
-  && ok "non-http scheme rejected" \
-  || bad "bad-url" "$R5"
-
-# Status is an Integer (200), serialized bare without quotes.
-grep -q '^200$' "$DRV_OUT" \
-  && ok "response status is integer 200" \
-  || bad "status-integer" "$(grep -A1 '^(ok-len 6 ' "$DRV_OUT" | tail -1)"
-
-echo "Results: $PASS passed, $FAIL failed"
-[ "$FAIL" = 0 ]

lib/commerce/api.sx

@@ -0,0 +1,56 @@
+;; lib/commerce/api.sx — public commerce surface.
+;;
+;; A session bundles a pricing context with a cart: {:ctx CTX :cart CART}.
+;; All operations are pure and return a new session. The total and the
+;; per-line breakdown are deterministic functions of (ctx, cart).
+;;
+;; commerce-checkout is a Phase-3 stub — the order lifecycle is a durable
+;; flow that suspends at the SumUp payment boundary.
+
+(define commerce-session (fn (ctx) {:cart empty-cart :ctx ctx}))
+
+(define commerce-ctx (fn (sess) (get sess :ctx)))
+(define commerce-cart (fn (sess) (get sess :cart)))
+(define commerce-lines (fn (sess) (cart-lines (get sess :cart))))
+(define commerce-count (fn (sess) (cart-count (get sess :cart))))
+
+(define
+  commerce-add
+  (fn
+    (sess sku variant qty)
+    (assoc sess :cart (cart-add (get sess :cart) sku variant qty))))
+
+(define
+  commerce-remove
+  (fn
+    (sess sku variant)
+    (assoc sess :cart (cart-remove (get sess :cart) sku variant))))
+
+(define
+  commerce-set-qty
+  (fn
+    (sess sku variant qty)
+    (assoc sess :cart (cart-set-qty (get sess :cart) sku variant qty))))
+
+;; True when the sku exists in the session's catalog snapshot.
+(define
+  commerce-can-add?
+  (fn (sess sku) (catalog-has? (ctx-catalog (get sess :ctx)) sku)))
+
+(define
+  commerce-total
+  (fn (sess) (cart-total (get sess :ctx) (get sess :cart))))
+
+;; Per-line audit breakdown — the "which line contributed what" view.
+(define
+  line-detail
+  (fn (ctx line) (let ((cat (ctx-catalog ctx))) {:sku (line-sku line) :unit (line-unit-price cat (line-sku line) (line-variant line)) :qty (line-qty line) :variant (line-variant line) :extended (line-extended cat line) :tax (line-tax ctx line)})))
+
+(define
+  commerce-explain
+  (fn
+    (sess)
+    (map (fn (l) (line-detail (get sess :ctx) l)) (get sess :cart))))
+
+;; Phase 3 — order lifecycle flow (reserve -> pay -> fulfil) lands here.
+(define commerce-checkout (fn (sess) {:note "order lifecycle flow lands in Phase 3" :phase 3 :status :not-implemented}))

lib/commerce/attribution.sx

@@ -0,0 +1,100 @@
+;; lib/commerce/attribution.sx — line-level discount attribution.
+;;
+;; The briefing's marquee backward query: "which line item triggered this
+;; discount?". promo.sx computes discount amounts at the class/order level;
+;; this layer answers the *scope* question relationally and in both directions:
+;;   forward  — which lines does code C touch?   (lines-for-code)
+;;   backward — which codes touch this line?     (codes-for-line)
+;; Both are the same relation promo-toucheso run with different vars bound.
+;;
+;; A :fixed promo is order-level (touches no single line); query those with
+;; order-level-codes. Only promos that actually apply (amount > 0) touch lines.
+
+;; Lines whose sku is in product-class `cls`.
+(define
+  class-lines
+  (fn
+    (ctx cart cls)
+    (filter
+      (fn (l) (= (catalog-class (ctx-catalog ctx) (line-sku l)) cls))
+      cart)))
+
+;; The lines a promo applies to (its scope). :fixed is order-level → no lines.
+(define
+  promo-lines
+  (fn
+    (ctx cart p)
+    (let
+      ((k (promo-kind p)))
+      (cond
+        ((= k :percent) (class-lines ctx cart (nth p 2)))
+        ((= k :member)
+          (if
+            (= (get ctx :customer) :member)
+            (class-lines ctx cart (nth p 2))
+            (list)))
+        ((= k :bundle)
+          (filter (fn (l) (= (line-sku l) (nth p 2))) cart))
+        (:else (list))))))
+
+;; Relation: promo `code` touches `line`. Only applying promos (amount > 0)
+;; touch anything, so an inapplicable promo contributes no pairs.
+(define
+  promo-toucheso
+  (fn
+    (ctx cart ruleset code line)
+    (fresh
+      (p)
+      (membero p ruleset)
+      (project
+        (p)
+        (if
+          (> (promo-amount ctx cart p) 0)
+          (mk-conj
+            (== code (promo-code p))
+            (membero line (promo-lines ctx cart p)))
+          fail)))))
+
+;; --- query helpers ---
+
+(define
+  lines-for-code
+  (fn
+    (ctx cart ruleset code)
+    (run* line (promo-toucheso ctx cart ruleset code line))))
+
+(define
+  codes-for-line
+  (fn
+    (ctx cart ruleset line)
+    (run* code (promo-toucheso ctx cart ruleset code line))))
+
+(define
+  line-touched-by?
+  (fn
+    (ctx cart ruleset code line)
+    (not
+      (empty?
+        (run
+          1
+          c
+          (mk-conj (promo-toucheso ctx cart ruleset code line) (== c true)))))))
+
+;; Applying order-level (:fixed) promos — discounts with no single line.
+(define
+  order-level-codes
+  (fn
+    (ctx cart ruleset)
+    (run*
+      code
+      (fresh
+        (p)
+        (membero p ruleset)
+        (project
+          (p)
+          (if
+            (and
+              (> (promo-amount ctx cart p) 0)
+              (= (promo-kind p) :fixed))
+            (== code (promo-code p))
+            fail))))))

lib/commerce/cart.sx

@@ -0,0 +1,86 @@
+;; lib/commerce/cart.sx — cart as an ordered list of line items.
+;;
+;; A cart is a native list of lines; a line is (list sku variant qty).
+;; All operations are pure: they return a new cart, never mutate. Line
+;; order is insertion order (stable) so totals are reproducible.
+;;
+;; cart-lineo is the relational view — because a line *is* a (sku variant qty)
+;; tuple, membero queries the cart directly, forward or backward.
+
+(define empty-cart (list))
+
+(define make-line (fn (sku variant qty) (list sku variant qty)))
+(define line-sku (fn (l) (nth l 0)))
+(define line-variant (fn (l) (nth l 1)))
+(define line-qty (fn (l) (nth l 2)))
+
+(define
+  same-line?
+  (fn
+    (l sku variant)
+    (and (= (line-sku l) sku) (= (line-variant l) variant))))
+
+(define
+  cart-qty
+  (fn
+    (cart sku variant)
+    (let
+      ((m (filter (fn (l) (same-line? l sku variant)) cart)))
+      (if (empty? m) 0 (line-qty (first m))))))
+
+(define
+  cart-remove
+  (fn
+    (cart sku variant)
+    (filter (fn (l) (not (same-line? l sku variant))) cart)))
+
+;; Add qty units; merges into an existing (sku,variant) line in place,
+;; otherwise appends a new line at the end.
+(define
+  cart-add
+  (fn
+    (cart sku variant qty)
+    (let
+      ((existing (cart-qty cart sku variant)))
+      (if
+        (= existing 0)
+        (append cart (list (make-line sku variant qty)))
+        (map
+          (fn
+            (l)
+            (if
+              (same-line? l sku variant)
+              (make-line sku variant (+ existing qty))
+              l))
+          cart)))))
+
+;; Set the absolute quantity; qty <= 0 removes the line.
+(define
+  cart-set-qty
+  (fn
+    (cart sku variant qty)
+    (if
+      (<= qty 0)
+      (cart-remove cart sku variant)
+      (if
+        (= (cart-qty cart sku variant) 0)
+        (append cart (list (make-line sku variant qty)))
+        (map
+          (fn
+            (l)
+            (if (same-line? l sku variant) (make-line sku variant qty) l))
+          cart)))))
+
+(define cart-empty? (fn (cart) (empty? cart)))
+(define cart-lines (fn (cart) cart))
+(define cart-skus (fn (cart) (map line-sku cart)))
+
+;; Total number of units across all lines.
+(define
+  cart-count
+  (fn (cart) (reduce (fn (acc l) (+ acc (line-qty l))) 0 cart)))
+
+;; Relational view of cart lines.
+(define
+  cart-lineo
+  (fn (cart sku variant qty) (membero (list sku variant qty) cart)))

lib/commerce/catalog.sx

@@ -0,0 +1,83 @@
+;; lib/commerce/catalog.sx — catalog snapshot + relational accessors.
+;;
+;; A catalog snapshot is an immutable dict:
+;;   {:products (list (list sku price class) ...)
+;;    :variants (list (list sku variant delta) ...)
+;;    :stock    (list (list sku variant qty) ...)}
+;;
+;; Money is integer minor units (pence/cents). class is a keyword product
+;; class consumed later by tax and promotion relations. delta is a signed
+;; price adjustment for a variant; qty is on-hand stock for (sku,variant).
+;;
+;; Accessor relations take the snapshot as the first argument and are fully
+;; multidirectional: (producto cat "widget" p c) binds p,c forward;
+;; (producto cat s 1000 c) enumerates every sku priced 1000 backward.
+
+(define empty-catalog {:products (list) :stock (list) :variants (list)})
+
+(define make-catalog (fn (products variants stock) {:products products :stock stock :variants variants}))
+
+(define cat-products (fn (cat) (get cat :products)))
+(define cat-variants (fn (cat) (get cat :variants)))
+(define cat-stock (fn (cat) (get cat :stock)))
+
+;; --- core fact relations ---
+
+(define
+  producto
+  (fn
+    (cat sku price class)
+    (membero (list sku price class) (get cat :products))))
+
+(define
+  varianto
+  (fn
+    (cat sku variant delta)
+    (membero (list sku variant delta) (get cat :variants))))
+
+(define
+  stocko
+  (fn
+    (cat sku variant qty)
+    (membero (list sku variant qty) (get cat :stock))))
+
+;; --- derived relations ---
+
+(define
+  priceo
+  (fn (cat sku price) (fresh (c) (producto cat sku price c))))
+
+(define
+  classo
+  (fn (cat sku class) (fresh (p) (producto cat sku p class))))
+
+;; Effective unit price of a (sku,variant): base + variant delta.
+(define
+  unit-priceo
+  (fn
+    (cat sku variant price)
+    (fresh
+      (base delta)
+      (priceo cat sku base)
+      (varianto cat sku variant delta)
+      (pluso-i base delta price))))
+
+;; --- deterministic lookups (first solution under fixed fact order) ---
+
+(define
+  catalog-price
+  (fn
+    (cat sku)
+    (let
+      ((rs (run 1 p (priceo cat sku p))))
+      (if (empty? rs) nil (first rs)))))
+
+(define
+  catalog-class
+  (fn
+    (cat sku)
+    (let
+      ((rs (run 1 c (classo cat sku c))))
+      (if (empty? rs) nil (first rs)))))
+
+(define catalog-has? (fn (cat sku) (not (nil? (catalog-price cat sku)))))

lib/commerce/conformance.sh

@@ -0,0 +1,153 @@
+#!/usr/bin/env bash
+# lib/commerce/conformance.sh — run commerce test suites in one sx_server
+# process per suite, emit scoreboard.json + scoreboard.md.
+#
+# commerce-on-sx builds pricing/promotion as miniKanren relations, so every
+# suite loads the miniKanren stack first, then the commerce modules.
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
+fi
+if [ ! -x "$SX_SERVER" ]; then
+  echo "ERROR: sx_server.exe not found." >&2
+  exit 1
+fi
+
+SUITES=(catalog cart price api promo stack quote ledger order recon federation attribution payment window nettax stock refund integration)
+
+OUT_JSON="lib/commerce/scoreboard.json"
+OUT_MD="lib/commerce/scoreboard.md"
+
+run_suite() {
+  local suite=$1
+  local file="lib/commerce/tests/${suite}.sx"
+  local TMP
+  TMP=$(mktemp)
+  cat > "$TMP" << EPOCHS
+(epoch 1)
+(load "spec/stdlib.sx")
+(load "lib/r7rs.sx")
+(load "lib/guest/match.sx")
+(load "lib/minikanren/unify.sx")
+(load "lib/minikanren/stream.sx")
+(load "lib/minikanren/goals.sx")
+(load "lib/minikanren/fresh.sx")
+(load "lib/minikanren/conde.sx")
+(load "lib/minikanren/run.sx")
+(load "lib/minikanren/relations.sx")
+(load "lib/minikanren/project.sx")
+(load "lib/minikanren/intarith.sx")
+(load "lib/minikanren/matche.sx")
+(load "lib/minikanren/defrel.sx")
+(load "lib/persist/event.sx")
+(load "lib/persist/backend.sx")
+(load "lib/persist/log.sx")
+(load "lib/persist/kv.sx")
+(load "lib/persist/idempotency.sx")
+(load "lib/guest/lex.sx")
+(load "lib/guest/reflective/env.sx")
+(load "lib/guest/reflective/quoting.sx")
+(load "lib/scheme/parser.sx")
+(load "lib/scheme/eval.sx")
+(load "lib/scheme/runtime.sx")
+(load "lib/flow/spec.sx")
+(load "lib/flow/store.sx")
+(load "lib/flow/remote.sx")
+(load "lib/flow/host.sx")
+(load "lib/flow/api.sx")
+(load "lib/commerce/catalog.sx")
+(load "lib/commerce/cart.sx")
+(load "lib/commerce/price.sx")
+(load "lib/commerce/api.sx")
+(load "lib/commerce/promo.sx")
+(load "lib/commerce/stack.sx")
+(load "lib/commerce/quote.sx")
+(load "lib/commerce/window.sx")
+(load "lib/commerce/nettax.sx")
+(load "lib/commerce/stock.sx")
+(load "lib/commerce/ledger.sx")
+(load "lib/commerce/order.sx")
+(load "lib/commerce/refund.sx")
+(load "lib/commerce/payment.sx")
+(load "lib/commerce/recon.sx")
+(load "lib/commerce/federation.sx")
+(load "lib/commerce/attribution.sx")
+(epoch 2)
+(eval "(define ct-pass 0)")
+(eval "(define ct-fail 0)")
+(eval "(define ct-fails (list))")
+(eval "(define commerce-test (fn (name got expected) (if (= got expected) (set! ct-pass (+ ct-pass 1)) (begin (set! ct-fail (+ ct-fail 1)) (append! ct-fails name)))))")
+(epoch 3)
+(load "${file}")
+(epoch 4)
+(eval "(list ct-pass ct-fail)")
+(eval "ct-fails")
+EPOCHS
+
+  local OUTPUT
+  OUTPUT=$(timeout 560 "$SX_SERVER" < "$TMP" 2>/dev/null)
+  rm -f "$TMP"
+
+  # The (list ct-pass ct-fail) result follows its (ok-len 2 N) ack line.
+  local LINE
+  LINE=$(echo "$OUTPUT" | grep -oE '^\([0-9]+ [0-9]+\)$' | tail -1)
+  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 commerce 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 '# commerce Conformance Scoreboard\n\n'
+  printf '_Generated by `lib/commerce/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 ]

lib/commerce/federation.sx

@@ -0,0 +1,86 @@
+;; lib/commerce/federation.sx — cross-instance catalog (federated marketplace).
+;;
+;; STUB: instances are registered in-process; there is no real network or
+;; ActivityPub transport here (that lives in the federation service). The point
+;; is the relational model: a federated catalog is just the UNION of each
+;; instance's product facts, tagged with origin, so the same miniKanren
+;; relations answer cross-instance questions — "which instances sell this sku?",
+;; "which is cheapest?" — as backward queries, no new query engine.
+
+(define federation-stub? true)
+
+(define make-federation (fn (instance cat) {:instances (list (list instance cat))}))
+
+(define
+  federation-add
+  (fn
+    (fed instance cat)
+    (assoc
+      fed
+      :instances (append (get fed :instances) (list (list instance cat))))))
+
+(define federation-instances (fn (fed) (map first (get fed :instances))))
+
+;; Flatten to (instance sku price class) origin-tagged tuples.
+(define
+  fed-products
+  (fn
+    (fed)
+    (reduce
+      (fn
+        (acc pair)
+        (let
+          ((instance (first pair)) (cat (nth pair 1)))
+          (append
+            acc
+            (map (fn (p) (cons instance p)) (get cat :products)))))
+      (list)
+      (get fed :instances))))
+
+;; --- relations over the federated catalog (multidirectional) ---
+
+(define
+  fed-producto
+  (fn
+    (fed instance sku price class)
+    (membero (list instance sku price class) (fed-products fed))))
+
+(define
+  fed-priceo
+  (fn
+    (fed instance sku price)
+    (fresh (c) (fed-producto fed instance sku price c))))
+
+;; --- query helpers ---
+
+;; Which instances carry a sku? (backward query)
+(define
+  instances-with-sku
+  (fn (fed sku) (run* inst (fresh (p c) (fed-producto fed inst sku p c)))))
+
+;; All (price instance) offers for a sku, in federation order.
+(define
+  sku-offers
+  (fn
+    (fed sku)
+    (run*
+      pair
+      (fresh
+        (inst p c)
+        (fed-producto fed inst sku p c)
+        (== pair (list p inst))))))
+
+;; Cheapest (price instance) for a sku — the deterministic selection layer.
+(define
+  cheapest-offer
+  (fn
+    (fed sku)
+    (let
+      ((offers (sku-offers fed sku)))
+      (if
+        (empty? offers)
+        nil
+        (reduce
+          (fn (best x) (if (< (first x) (first best)) x best))
+          (first offers)
+          offers)))))

lib/commerce/ledger.sx

@@ -0,0 +1,176 @@
+;; lib/commerce/ledger.sx — the order ledger as a persist event stream.
+;;
+;; Each order is an append-only stream "order/<id>" in a persist backend.
+;; Order state is never stored directly — it is a projection (fold) over the
+;; events, so the ledger is the single source of truth and replays identically.
+;;
+;; Lifecycle events:
+;;   :created   quote snapshot {:subtotal :discount :tax :total :codes ...}
+;;   :reserved  stock reserved
+;;   :paid      {:amount :ref}  — recorded idempotently on the payment ref
+;;   :fulfilled order shipped/delivered
+;;   :cancelled / :refunded
+;;
+;; Idempotency: the SumUp webhook can fire twice for one payment. order-pay
+;; uses persist/append-once keyed by the payment ref, so a replayed webhook
+;; yields the SAME :paid event without double-recording. Reconciliation then
+;; detects genuine mismatches (paid != ordered) across the whole ledger.
+
+(define order-stream (fn (order-id) (str "order/" order-id)))
+
+;; --- writes ---
+
+(define
+  order-create
+  (fn
+    (b order-id at quote)
+    (persist/append b (order-stream order-id) :created at quote)))
+
+(define
+  order-reserve
+  (fn
+    (b order-id at data)
+    (persist/append b (order-stream order-id) :reserved at data)))
+
+;; Idempotent on payment ref — a replayed webhook does not double-record.
+(define
+  order-pay
+  (fn
+    (b order-id ref at amount)
+    (persist/append-once b (order-stream order-id) ref :paid at {:amount amount :ref ref})))
+
+(define
+  order-fulfil
+  (fn
+    (b order-id at data)
+    (persist/append b (order-stream order-id) :fulfilled at data)))
+
+(define
+  order-cancel
+  (fn
+    (b order-id at reason)
+    (persist/append b (order-stream order-id) :cancelled at {:reason reason})))
+
+(define
+  order-refund
+  (fn
+    (b order-id ref at amount)
+    (persist/append-once
+      b
+      (order-stream order-id)
+      (str "refund/" ref)
+      :refunded at
+      {:amount amount :ref ref})))
+
+;; --- reads ---
+
+(define
+  order-events
+  (fn (b order-id) (persist/read b (order-stream order-id))))
+
+;; --- projections over an event list ---
+
+(define
+  order-status-of
+  (fn
+    (events)
+    (reduce
+      (fn
+        (st e)
+        (let
+          ((t (persist/event-type e)))
+          (cond
+            ((= t :created) :pending)
+            ((= t :reserved) :reserved)
+            ((= t :paid) :paid)
+            ((= t :fulfilled) :fulfilled)
+            ((= t :cancelled) :cancelled)
+            ((= t :refunded) :refunded)
+            (:else st))))
+      :new events)))
+
+(define
+  order-total-of
+  (fn
+    (events)
+    (let
+      ((created (filter (fn (e) (= (persist/event-type e) :created)) events)))
+      (if
+        (empty? created)
+        0
+        (get (persist/event-data (first created)) :total)))))
+
+(define
+  order-paid-amount-of
+  (fn
+    (events)
+    (reduce
+      (fn
+        (acc e)
+        (if
+          (= (persist/event-type e) :paid)
+          (+ acc (get (persist/event-data e) :amount))
+          acc))
+      0
+      events)))
+
+(define
+  order-refunded-amount-of
+  (fn
+    (events)
+    (reduce
+      (fn
+        (acc e)
+        (if
+          (= (persist/event-type e) :refunded)
+          (+ acc (get (persist/event-data e) :amount))
+          acc))
+      0
+      events)))
+
+;; Net settled = paid - refunded. Reconciliation compares this to the order
+;; total, but only once a payment exists.
+(define
+  order-recon-of
+  (fn
+    (events)
+    (let
+      ((net (- (order-paid-amount-of events) (order-refunded-amount-of events)))
+        (total (order-total-of events))
+        (has-paid (some (fn (e) (= (persist/event-type e) :paid)) events)))
+      (cond
+        ((not has-paid) :unpaid)
+        ((= net total) :ok)
+        ((< net total) :underpaid)
+        (:else :overpaid)))))
+
+;; --- backend-level helpers ---
+
+(define
+  order-status
+  (fn (b order-id) (order-status-of (order-events b order-id))))
+(define
+  order-total
+  (fn (b order-id) (order-total-of (order-events b order-id))))
+(define
+  order-paid
+  (fn (b order-id) (order-paid-amount-of (order-events b order-id))))
+(define
+  order-recon
+  (fn (b order-id) (order-recon-of (order-events b order-id))))
+
+(define order-ids (fn (b) (persist/backend-streams b)))
+
+;; Streams whose net payment does not match the order total (true mismatches,
+;; excluding orders that are simply not yet paid).
+(define
+  ledger-mismatches
+  (fn
+    (b)
+    (filter
+      (fn
+        (s)
+        (let
+          ((r (order-recon-of (persist/read b s))))
+          (or (= r :underpaid) (= r :overpaid))))
+      (persist/backend-streams b))))

lib/commerce/nettax.sx

@@ -0,0 +1,80 @@
+;; lib/commerce/nettax.sx — discount-aware tax (alternative policy).
+;;
+;; price.sx / quote.sx tax the GROSS per-line amounts (discount reduces payable
+;; but not the tax base). This module is the alternative explicit policy: tax the
+;; NET (post-discount) base. The basket-level discount is allocated across lines
+;; in proportion to each line's extended price, with a deterministic
+;; largest-remainder pass so per-line shares sum EXACTLY to the discount; tax is
+;; then charged on each line's net at its class rate.
+;;
+;; Both policies are reproducible from (ctx, cart, ruleset, exclusions); pick the
+;; one the jurisdiction requires. cart-quote-net mirrors cart-quote's shape.
+
+(define ct-sum (fn (xs) (reduce (fn (a x) (+ a x)) 0 xs)))
+
+;; Add 1 to the first `rem` elements (deterministic remainder distribution).
+(define
+  ct-add-rem
+  (fn
+    (xs rem)
+    (cond
+      ((empty? xs) (list))
+      ((> rem 0)
+        (cons
+          (+ (first xs) 1)
+          (ct-add-rem (rest xs) (- rem 1))))
+      (:else xs))))
+
+;; Per-line discount allocation (parallel to cart), summing exactly to
+;; total-discount, proportional to line-extended share.
+(define
+  allocate-discount
+  (fn
+    (cat cart total-discount)
+    (let
+      ((sub (cart-subtotal cat cart)))
+      (if
+        (= sub 0)
+        (map (fn (l) 0) cart)
+        (let
+          ((floors (map (fn (l) (quotient (* total-discount (line-extended cat l)) sub)) cart)))
+          (ct-add-rem floors (- total-discount (ct-sum floors))))))))
+
+;; Tax on one line's net (extended - allocated discount), clamped at 0.
+(define
+  net-line-tax
+  (fn
+    (ctx line alloc)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((net (- (line-extended cat line) alloc)))
+        (apply-bps
+          (if (< net 0) 0 net)
+          (rate-bps
+            (get ctx :tax-rules)
+            (get ctx :jurisdiction)
+            (catalog-class cat (line-sku line))
+            (get ctx :customer)))))))
+
+(define
+  net-tax
+  (fn
+    (ctx cart allocations)
+    (ct-sum
+      (map (fn (line alloc) (net-line-tax ctx line alloc)) cart allocations))))
+
+;; Discount-aware quote: tax computed on the net (post-discount) base.
+(define
+  cart-quote-net
+  (fn
+    (ctx cart ruleset exclusions)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((sub (cart-subtotal cat cart))
+          (disc (best-promo-discount ctx cart ruleset exclusions))
+          (codes (best-promo-codes ctx cart ruleset exclusions)))
+        (let
+          ((tax (net-tax ctx cart (allocate-discount cat cart disc))))
+          {:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax})))))

lib/commerce/order.sx

@@ -0,0 +1,119 @@
+;; lib/commerce/order.sx — order lifecycle as a durable flow-on-sx flow.
+;;
+;; The lifecycle (reserve -> await payment -> fulfil) is a Scheme flow running
+;; in the flow-on-sx guest (lib/flow). The flow is PURE ORCHESTRATION: it
+;; carries only the order-id and enforces step ordering + the suspension at the
+;; payment IO boundary. All IO/state lives in SX: the SX driver here services
+;; each flow request by appending to the persist ledger (ledger.sx).
+;;
+;;   reserve  -> SX appends :reserved, resumes  (synchronous host effect)
+;;   payment  -> flow stays SUSPENDED until the SumUp webhook resumes it
+;;   fulfil   -> SX appends :fulfilled, resumes (synchronous host effect)
+;;
+;; Durability: the flow's replay log is plain data (flow-store-export), so a
+;; suspended order survives a process restart — order-flow-restart! simulates
+;; that entirely Scheme-side. Idempotency: order-settle! only resumes a flow
+;; still waiting on payment, so a replayed webhook is a no-op at the flow level,
+;; and order-pay is idempotent at the ledger level.
+
+;; The flow definition (Scheme source). oid is in scope throughout the begin.
+(define
+  order-flow-src
+  "(defflow order-lifecycle (lambda (oid) (begin (request (quote reserve) oid) (request (quote payment) oid) (request (quote fulfil) oid))))")
+
+;; Build a flow env with the order flow registered. Never returns the env from
+;; an eval boundary (the env is large/cyclic — serializing it hangs).
+(define
+  order-make-env
+  (fn
+    ()
+    (let
+      ((env (flow-make-env)))
+      (begin (flow-run-in env order-flow-src) env))))
+
+;; --- thin Scheme bridge (string-interpolated flow ops) ---
+
+(define
+  order-flow-start
+  (fn
+    (env oid)
+    (flow-run-in env (str "(flow/start order-lifecycle \"" oid "\")"))))
+
+(define
+  order-flow-resume
+  (fn
+    (env id sym)
+    (flow-run-in env (str "(flow/resume " id " (quote " sym "))"))))
+
+(define
+  order-flow-status
+  (fn (env id) (flow-run-in env (str "(flow/status " id ")"))))
+(define
+  order-flow-result
+  (fn (env id) (flow-run-in env (str "(flow/result " id ")"))))
+
+;; The request kind the flow with this id is waiting on, or nil if it is not
+;; suspended on a host request (done / cancelled / unknown).
+(define
+  order-flow-waiting
+  (fn
+    (env id)
+    (let
+      ((reqs (flow-run-in env "(flow-host-requests)")))
+      (let
+        ((mine (filter (fn (r) (= (first r) id)) reqs)))
+        (if (empty? mine) nil (nth (first mine) 1))))))
+
+;; Id out of a (flow-suspended id tag) start/resume result.
+(define order-susp-id (fn (susp) (nth susp 1)))
+
+;; --- high-level lifecycle (flow + ledger composed) ---
+
+;; Create the order, start the flow, service the reserve step, and leave the
+;; flow suspended at payment. Returns the flow id (needed to settle later).
+(define
+  order-begin!
+  (fn
+    (env b oid at quote)
+    (begin
+      (order-create b oid at quote)
+      (let
+        ((id (order-susp-id (order-flow-start env oid))))
+        (begin
+          (order-reserve b oid (+ at 1) {})
+          (order-flow-resume env id :reserved)
+          id)))))
+
+;; Settle a payment: record it, resume the flow past payment, service fulfil.
+;; Idempotent — only acts when the flow is still waiting on payment, so a
+;; replayed webhook returns :already-settled without double-charging.
+(define
+  order-settle!
+  (fn
+    (env b id oid ref at amount)
+    (if
+      (= (order-flow-waiting env id) "payment")
+      (begin
+        (order-pay b oid ref at amount)
+        (order-flow-resume env id :paid)
+        (order-fulfil b oid (+ at 1) {})
+        (order-flow-resume env id :fulfilled)
+        :settled)
+      :already-settled)))
+
+;; Simulate a process restart: export the flow store, reset the runtime, reload
+;; the flow definition, reimport the store. Done entirely Scheme-side so the
+;; (large) store is never marshalled across the boundary. The persist ledger is
+;; a separate store and is unaffected. Suspended flows resume afterwards.
+(define
+  order-flow-restart!
+  (fn
+    (env)
+    (flow-run-in
+      env
+      (str
+        "(begin (define _saved (flow-store-export)) "
+        flow-reset-src
+        " "
+        order-flow-src
+        " (flow-store-import! _saved) #t)"))))

lib/commerce/payment.sx

@@ -0,0 +1,41 @@
+;; lib/commerce/payment.sx — provider-neutral payment-request envelope.
+;;
+;; The order flow (order.sx) suspends on `(request 'payment oid)` — it carries
+;; ONLY the order-id and calls no provider. This layer materialises, at the IO
+;; edge, the envelope a provider adapter needs to initiate payment:
+;;
+;;   {:order oid :amount <ledger total> :currency C :return-url U}
+;;
+;; amount comes from the ledger (the :created quote total); currency + return-url
+;; are host/provider config (legitimately host-supplied). The engine stays
+;; vendor-agnostic: SumUp/Stripe/etc. adapters consume this envelope, and
+;; order-settle!(ref, amount) is the vendor-neutral resume seam. No provider
+;; SDK, HTTP, or webhook parsing lives here — that is the orders service's job.
+
+(define payment-request (fn (b oid currency return-url) {:order oid :amount (order-total b oid) :return-url return-url :currency currency}))
+
+(define payment-request-order (fn (pr) (get pr :order)))
+(define payment-request-amount (fn (pr) (get pr :amount)))
+(define payment-request-currency (fn (pr) (get pr :currency)))
+(define payment-request-return-url (fn (pr) (get pr :return-url)))
+
+;; A Scheme string carried as a flow payload round-trips back to SX wrapped as
+;; {:scm-string "..."}; unwrap it to the bare order-id.
+(define
+  scm->string
+  (fn
+    (v)
+    (if (and (dict? v) (has-key? v :scm-string)) (get v :scm-string) v)))
+
+;; Host poller seam: every order currently suspended awaiting payment, each with
+;; its envelope. A provider adapter iterates these, initiates payment, and later
+;; calls order-settle! when the webhook arrives. Needs the flow env.
+(define
+  pending-payments
+  (fn
+    (env b currency return-url)
+    (let
+      ((reqs (flow-run-in env "(flow-host-requests)")))
+      (map
+        (fn (r) {:id (first r) :request (payment-request b (scm->string (nth r 2)) currency return-url)})
+        (filter (fn (r) (= (nth r 1) "payment")) reqs)))))

lib/commerce/price.sx

@@ -0,0 +1,110 @@
+;; lib/commerce/price.sx — deterministic subtotal + jurisdiction-relational tax.
+;;
+;; A pricing context bundles the inputs that make a total reproducible:
+;;   {:catalog CAT :tax-rules RULES :jurisdiction J :customer C}
+;; Same context + same cart => identical total, every run.
+;;
+;; Tax is NOT a hardcoded VAT rate. Rules are facts indexed by
+;;   (jurisdiction, product-class, customer-class) -> rate-bps
+;; where rate-bps is an integer in basis points (2000 = 20%). taxo queries
+;; them multidirectionally. Money stays in integer minor units; rounding is
+;; half-up per line via integer arithmetic only — never floats.
+
+(define
+  make-pricing-context
+  (fn (catalog tax-rules jurisdiction customer) {:customer customer :jurisdiction jurisdiction :catalog catalog :tax-rules tax-rules}))
+
+(define ctx-catalog (fn (ctx) (get ctx :catalog)))
+
+;; --- unit + line pricing ---
+
+;; Variant delta, defaulting to 0 when the (sku,variant) has no variant fact.
+(define
+  variant-delta
+  (fn
+    (cat sku variant)
+    (let
+      ((rs (run 1 d (varianto cat sku variant d))))
+      (if (empty? rs) 0 (first rs)))))
+
+;; Effective unit price = base price + variant delta. nil if sku unknown.
+(define
+  line-unit-price
+  (fn
+    (cat sku variant)
+    (let
+      ((base (catalog-price cat sku)))
+      (if (nil? base) nil (+ base (variant-delta cat sku variant))))))
+
+;; Extended (line) price = unit price * quantity.
+(define
+  line-extended
+  (fn
+    (cat line)
+    (*
+      (line-unit-price cat (line-sku line) (line-variant line))
+      (line-qty line))))
+
+(define
+  cart-subtotal
+  (fn
+    (cat cart)
+    (reduce (fn (acc l) (+ acc (line-extended cat l))) 0 cart)))
+
+;; --- tax (jurisdiction-relational) ---
+
+;; rules: (list (list jurisdiction class customer bps) ...)
+(define
+  taxo
+  (fn
+    (rules juris class cust bps)
+    (membero (list juris class cust bps) rules)))
+
+;; Deterministic rate lookup; 0 when no rule matches.
+(define
+  rate-bps
+  (fn
+    (rules juris class cust)
+    (let
+      ((rs (run 1 b (taxo rules juris class cust b))))
+      (if (empty? rs) 0 (first rs)))))
+
+;; Apply a basis-point rate to an integer amount, rounding half up.
+(define
+  apply-bps
+  (fn (amount bps) (quotient (+ (* amount bps) 5000) 10000)))
+
+(define
+  line-tax
+  (fn
+    (ctx line)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((class (catalog-class cat (line-sku line))))
+        (apply-bps
+          (line-extended cat line)
+          (rate-bps
+            (get ctx :tax-rules)
+            (get ctx :jurisdiction)
+            class
+            (get ctx :customer)))))))
+
+(define
+  cart-tax
+  (fn
+    (ctx cart)
+    (reduce (fn (acc l) (+ acc (line-tax ctx l))) 0 cart)))
+
+;; --- total ---
+
+;; Returns {:subtotal :discounts :tax :total}. discounts is 0 until Phase 2.
+(define
+  cart-total
+  (fn
+    (ctx cart)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((sub (cart-subtotal cat cart)) (tax (cart-tax ctx cart)))
+        {:subtotal sub :discounts 0 :total (+ sub tax) :tax tax}))))

lib/commerce/promo.sx

@@ -0,0 +1,153 @@
+;; lib/commerce/promo.sx — promotions as relations over the cart + catalog.
+;;
+;; A promo is a tagged tuple; the second field is always its code:
+;;   (:percent code class pct-bps)   pct-bps off every line of product-class
+;;   (:fixed   code threshold amount) amount off when subtotal >= threshold
+;;   (:bundle  code sku n)            every nth unit of sku is free
+;;   (:member  code class pct-bps)    like :percent, members only
+;;
+;; A ruleset is a list of promo tuples. The discount a promo yields on a
+;; given cart is a pure integer computation (minor units); the *enumeration*
+;; of which promos apply is relational, so promo-applieso runs forward
+;; ("which codes apply and for how much?") and backward ("which code yields
+;; this discount?"). Stacking precedence is a separate layer (stack.sx).
+
+(define promo-kind (fn (p) (nth p 0)))
+(define promo-code (fn (p) (nth p 1)))
+
+;; Extended price of all lines whose sku is in product-class `class`.
+(define
+  class-extended
+  (fn
+    (ctx cart class)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (reduce
+        (fn
+          (acc l)
+          (if
+            (= (catalog-class cat (line-sku l)) class)
+            (+ acc (line-extended cat l))
+            acc))
+        0
+        cart))))
+
+(define
+  sku-qty
+  (fn
+    (cart sku)
+    (reduce
+      (fn (acc l) (if (= (line-sku l) sku) (+ acc (line-qty l)) acc))
+      0
+      cart)))
+
+;; --- per-type discount amounts (pure, integer minor units) ---
+
+(define
+  percent-amount
+  (fn
+    (ctx cart p)
+    (apply-bps
+      (class-extended ctx cart (nth p 2))
+      (nth p 3))))
+
+(define
+  fixed-amount
+  (fn
+    (ctx cart p)
+    (let
+      ((sub (cart-subtotal (ctx-catalog ctx) cart)))
+      (if
+        (>= sub (nth p 2))
+        (min (nth p 3) sub)
+        0))))
+
+(define
+  bundle-amount
+  (fn
+    (ctx cart p)
+    (let
+      ((sku (nth p 2)) (n (nth p 3)))
+      (let
+        ((free (quotient (sku-qty cart sku) n)))
+        (* free (catalog-price (ctx-catalog ctx) sku))))))
+
+(define
+  member-amount
+  (fn
+    (ctx cart p)
+    (if
+      (= (get ctx :customer) :member)
+      (apply-bps
+        (class-extended ctx cart (nth p 2))
+        (nth p 3))
+      0)))
+
+;; Discount this promo yields on this cart (0 if it does not apply).
+(define
+  promo-amount
+  (fn
+    (ctx cart p)
+    (let
+      ((k (promo-kind p)))
+      (cond
+        ((= k :percent) (percent-amount ctx cart p))
+        ((= k :fixed) (fixed-amount ctx cart p))
+        ((= k :bundle) (bundle-amount ctx cart p))
+        ((= k :member) (member-amount ctx cart p))
+        (:else 0)))))
+
+;; --- relational enumeration ---
+
+;; (code, amount) for every promo in the ruleset (amount may be 0).
+(define
+  promo-discounto
+  (fn
+    (ctx cart ruleset code amount)
+    (fresh
+      (p)
+      (membero p ruleset)
+      (project
+        (p)
+        (== code (promo-code p))
+        (== amount (promo-amount ctx cart p))))))
+
+;; (code, amount) restricted to promos that actually apply (amount > 0).
+(define
+  promo-applieso
+  (fn
+    (ctx cart ruleset code amount)
+    (fresh
+      (p)
+      (membero p ruleset)
+      (project
+        (p)
+        (if
+          (> (promo-amount ctx cart p) 0)
+          (mk-conj
+            (== code (promo-code p))
+            (== amount (promo-amount ctx cart p)))
+          fail)))))
+
+;; --- deterministic helpers ---
+
+;; List of (list code amount) for applicable promos, in ruleset order.
+(define
+  applicable-promos
+  (fn
+    (ctx cart ruleset)
+    (run*
+      pair
+      (fresh
+        (code amount)
+        (promo-applieso ctx cart ruleset code amount)
+        (== pair (list code amount))))))
+
+;; Discount for one code (0 if absent / inapplicable).
+(define
+  promo-amount-for
+  (fn
+    (ctx cart ruleset code)
+    (let
+      ((rs (run 1 a (promo-applieso ctx cart ruleset code a))))
+      (if (empty? rs) 0 (first rs)))))

lib/commerce/quote.sx

@@ -0,0 +1,36 @@
+;; lib/commerce/quote.sx — the final priced quote: price + promo + stacking.
+;;
+;; A quote is the deterministic composition of the pricing pipeline for a
+;; (context, cart, ruleset, exclusions) tuple:
+;;   {:subtotal S :discount D :tax T :total (S - D + T) :codes (...)}
+;;
+;; Tax policy (explicit, for the determinism contract): tax is computed on the
+;; GROSS per-line amounts (pre-discount), via price.sx cart-tax. The best
+;; promo stacking reduces the payable total but not the tax base. Same inputs
+;; always yield the same quote — this is the value the order flow carries.
+
+(define
+  cart-quote
+  (fn
+    (ctx cart ruleset exclusions)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((sub (cart-subtotal cat cart))
+          (disc (best-promo-discount ctx cart ruleset exclusions))
+          (tax (cart-tax ctx cart))
+          (codes (best-promo-codes ctx cart ruleset exclusions)))
+        {:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax}))))
+
+(define quote-subtotal (fn (q) (get q :subtotal)))
+(define quote-discount (fn (q) (get q :discount)))
+(define quote-tax (fn (q) (get q :tax)))
+(define quote-total (fn (q) (get q :total)))
+(define quote-codes (fn (q) (get q :codes)))
+
+;; Session-level convenience (a session is {:ctx :cart}).
+(define
+  session-quote
+  (fn
+    (sess ruleset exclusions)
+    (cart-quote (get sess :ctx) (get sess :cart) ruleset exclusions)))

lib/commerce/recon.sx

@@ -0,0 +1,100 @@
+;; lib/commerce/recon.sx — reconciliation as relational queries over the ledger.
+;;
+;; The ledger (ledger.sx) is the source of truth; reconciliation projects it
+;; into per-order summary tuples and then asks miniKanren questions about them.
+;; "Which orders are overpaid?" / "which order settled to net N?" are backward
+;; queries (run*) over the same relation, not separate code paths.
+;;
+;; A summary tuple is positional:
+;;   (order-stream total paid refunded net status)
+;; net = paid - refunded; status = :unpaid|:ok|:underpaid|:overpaid.
+
+(define
+  order-summary
+  (fn
+    (b stream)
+    (let
+      ((events (persist/read b stream)))
+      (let
+        ((total (order-total-of events))
+          (paid (order-paid-amount-of events))
+          (refunded (order-refunded-amount-of events)))
+        (list
+          stream
+          total
+          paid
+          refunded
+          (- paid refunded)
+          (order-recon-of events))))))
+
+(define
+  ledger-summaries
+  (fn (b) (map (fn (s) (order-summary b s)) (persist/backend-streams b))))
+
+;; --- relations over the summary set ---
+
+(define
+  summaryo
+  (fn
+    (summaries id total paid refunded net status)
+    (membero (list id total paid refunded net status) summaries)))
+
+(define
+  recon-statuso
+  (fn
+    (summaries id status)
+    (fresh (t p r n) (summaryo summaries id t p r n status))))
+
+(define
+  neto
+  (fn
+    (summaries id net)
+    (fresh (t p r status) (summaryo summaries id t p r net status))))
+
+;; A mismatch is any order whose money does not reconcile (over or under).
+(define
+  mismatcho
+  (fn
+    (summaries id)
+    (fresh
+      (status)
+      (recon-statuso summaries id status)
+      (conde ((== status :underpaid)) ((== status :overpaid))))))
+
+;; --- deterministic query helpers (run* over the live ledger) ---
+
+(define
+  orders-with-status
+  (fn (b status) (run* id (recon-statuso (ledger-summaries b) id status))))
+
+(define overpaid-orders (fn (b) (orders-with-status b :overpaid)))
+(define underpaid-orders (fn (b) (orders-with-status b :underpaid)))
+(define settled-orders (fn (b) (orders-with-status b :ok)))
+(define unpaid-orders (fn (b) (orders-with-status b :unpaid)))
+
+(define
+  mismatched-orders
+  (fn (b) (run* id (mismatcho (ledger-summaries b) id))))
+
+;; Backward: which order(s) settled to a given net amount?
+(define
+  orders-with-net
+  (fn (b net) (run* id (neto (ledger-summaries b) id net))))
+
+;; Total signed discrepancy across the ledger (net - total over paid orders);
+;; 0 when every settled order reconciles exactly.
+(define
+  ledger-discrepancy
+  (fn
+    (b)
+    (reduce
+      (fn
+        (acc s)
+        (let
+          ((status (nth s 5)))
+          (if
+            (= status :unpaid)
+            acc
+            (+ acc (- (nth s 4) (nth s 1))))))
+      0
+      (ledger-summaries b))))

lib/commerce/refund.sx

@@ -0,0 +1,97 @@
+;; lib/commerce/refund.sx — refund lifecycle as a second flow-on-sx flow.
+;;
+;; A refund is request → approve → settle, with TWO genuine suspension points:
+;; approval (a human/policy decision) and settlement (the provider issuing the
+;; refund). Like order.sx the flow is pure orchestration carrying only the
+;; order-id; the SX driver does all ledger IO and reuses order.sx's generic flow
+;; helpers (order-flow-waiting/-resume/-status, order-susp-id).
+;;
+;;   refund-begin!   → ledger :refund-requested, flow suspends at 'approve
+;;   refund-approve! → resume past approval, flow suspends at 'settle
+;;   refund-settle!  → ledger :refunded (idempotent), flow completes
+;;   refund-reject!  → ledger :refund-rejected, flow cancelled
+;;
+;; Only :refunded moves the books (recon.sx), so a requested-but-unsettled or
+;; rejected refund leaves reconciliation unchanged.
+
+(define
+  refund-flow-src
+  "(defflow refund-lifecycle (lambda (oid) (begin (request (quote approve) oid) (request (quote settle) oid))))")
+
+(define
+  refund-make-env
+  (fn
+    ()
+    (let
+      ((env (flow-make-env)))
+      (begin (flow-run-in env refund-flow-src) env))))
+
+;; Register the refund flow into an existing (e.g. order) env.
+(define
+  refund-flow-load!
+  (fn (env) (begin (flow-run-in env refund-flow-src) env)))
+
+(define
+  refund-flow-start
+  (fn
+    (env oid)
+    (flow-run-in env (str "(flow/start refund-lifecycle \"" oid "\")"))))
+
+;; --- ledger writes ---
+
+(define
+  refund-request
+  (fn
+    (b oid ref at amount)
+    (persist/append-once
+      b
+      (order-stream oid)
+      (str "refund-req/" ref)
+      :refund-requested at
+      {:amount amount :ref ref})))
+
+;; --- lifecycle ---
+
+;; Open a refund: record the request, start the flow, suspend at approval.
+(define
+  refund-begin!
+  (fn
+    (env b oid ref at amount)
+    (begin
+      (refund-request b oid ref at amount)
+      (order-susp-id (refund-flow-start env oid)))))
+
+(define
+  refund-approve!
+  (fn
+    (env id)
+    (if
+      (= (order-flow-waiting env id) "approve")
+      (begin (order-flow-resume env id :approved) :approved)
+      :not-pending-approval)))
+
+(define
+  refund-reject!
+  (fn
+    (env b oid id at reason)
+    (if
+      (= (order-flow-waiting env id) "approve")
+      (begin
+        (persist/append b (order-stream oid) :refund-rejected at {:reason reason})
+        (flow-run-in env (str "(flow/cancel " id ")"))
+        :rejected)
+      :not-pending-approval)))
+
+;; Settle (provider issued the refund): idempotent — only acts while waiting on
+;; settle, so a replayed provider callback returns :already-settled.
+(define
+  refund-settle!
+  (fn
+    (env b id oid ref at amount)
+    (if
+      (= (order-flow-waiting env id) "settle")
+      (begin
+        (order-refund b oid ref at amount)
+        (order-flow-resume env id :settled)
+        :settled)
+      :already-settled)))

lib/commerce/scoreboard.json

@@ -0,0 +1,25 @@
+{
+  "suites": {
+    "catalog": {"pass": 16, "fail": 0},
+    "cart": {"pass": 18, "fail": 0},
+    "price": {"pass": 20, "fail": 0},
+    "api": {"pass": 12, "fail": 0},
+    "promo": {"pass": 17, "fail": 0},
+    "stack": {"pass": 16, "fail": 0},
+    "quote": {"pass": 13, "fail": 0},
+    "ledger": {"pass": 20, "fail": 0},
+    "order": {"pass": 22, "fail": 0},
+    "recon": {"pass": 20, "fail": 0},
+    "federation": {"pass": 12, "fail": 0},
+    "attribution": {"pass": 16, "fail": 0},
+    "payment": {"pass": 7, "fail": 0},
+    "window": {"pass": 19, "fail": 0},
+    "nettax": {"pass": 11, "fail": 0},
+    "stock": {"pass": 19, "fail": 0},
+    "refund": {"pass": 20, "fail": 0},
+    "integration": {"pass": 19, "fail": 0}
+  },
+  "total_pass": 297,
+  "total_fail": 0,
+  "total": 297
+}

lib/commerce/scoreboard.md

@@ -0,0 +1,25 @@
+# commerce Conformance Scoreboard
+
+_Generated by `lib/commerce/conformance.sh`_
+
+| Suite | Pass | Fail | Total |
+|-------|-----:|-----:|------:|
+| catalog | 16 | 0 | 16 |
+| cart | 18 | 0 | 18 |
+| price | 20 | 0 | 20 |
+| api | 12 | 0 | 12 |
+| promo | 17 | 0 | 17 |
+| stack | 16 | 0 | 16 |
+| quote | 13 | 0 | 13 |
+| ledger | 20 | 0 | 20 |
+| order | 22 | 0 | 22 |
+| recon | 20 | 0 | 20 |
+| federation | 12 | 0 | 12 |
+| attribution | 16 | 0 | 16 |
+| payment | 7 | 0 | 7 |
+| window | 19 | 0 | 19 |
+| nettax | 11 | 0 | 11 |
+| stock | 19 | 0 | 19 |
+| refund | 20 | 0 | 20 |
+| integration | 19 | 0 | 19 |
+| **Total** | **297** | **0** | **297** |

lib/commerce/stack.sx

@@ -0,0 +1,121 @@
+;; lib/commerce/stack.sx — promotion stacking precedence + best price.
+;;
+;; Per the miniKanren design rule, precedence is NOT encoded inside the promo
+;; rules. promo.sx enumerates which promos apply; this layer enumerates which
+;; *combinations* are legal and selects the best one by an explicit cost
+;; function (max total discount = min price).
+;;
+;; Exclusivity is a list of unordered code pairs that may not both apply:
+;;   exclusions = (list (list code-a code-b) ...)
+;; A stacking is a subset of applicable (code amount) pairs containing no
+;; excluded pair. valid-stackings enumerates them; best-stacking is the
+;; deterministic selection layer; stacking-by-totalo is the backward query
+;; ("which legal stacking yields this total discount?").
+
+(define
+  excluded-pair?
+  (fn
+    (exclusions a b)
+    (some
+      (fn
+        (p)
+        (or
+          (and (= (first p) a) (= (nth p 1) b))
+          (and (= (first p) b) (= (nth p 1) a))))
+      exclusions)))
+
+;; True when no two distinct codes in the list are mutually excluded.
+(define
+  compatible?
+  (fn
+    (exclusions codes)
+    (every?
+      (fn
+        (a)
+        (every?
+          (fn (b) (or (= a b) (not (excluded-pair? exclusions a b))))
+          codes))
+      codes)))
+
+;; All subsets of xs, preserving element order. 2^n entries.
+(define
+  powerset
+  (fn
+    (xs)
+    (if
+      (empty? xs)
+      (list (list))
+      (let
+        ((r (powerset (cdr xs))))
+        (append r (map (fn (s) (cons (first xs) s)) r))))))
+
+(define stacking-codes (fn (st) (map first st)))
+
+(define
+  stacking-total
+  (fn
+    (st)
+    (reduce (fn (acc pair) (+ acc (nth pair 1))) 0 st)))
+
+;; Every legal stacking of the applicable (code amount) pairs.
+(define
+  valid-stackings
+  (fn
+    (exclusions applicable)
+    (filter
+      (fn (st) (compatible? exclusions (stacking-codes st)))
+      (powerset applicable))))
+
+;; Deterministic selection: the legal stacking with the greatest total
+;; discount; ties keep the earlier (stable) candidate, so the result is a
+;; reproducible function of (exclusions, applicable).
+(define
+  best-stacking
+  (fn
+    (exclusions applicable)
+    (reduce
+      (fn
+        (best st)
+        (if (> (stacking-total st) (stacking-total best)) st best))
+      (list)
+      (valid-stackings exclusions applicable))))
+
+(define
+  best-discount
+  (fn
+    (exclusions applicable)
+    (stacking-total (best-stacking exclusions applicable))))
+
+(define
+  best-codes
+  (fn
+    (exclusions applicable)
+    (stacking-codes (best-stacking exclusions applicable))))
+
+;; Backward query: legal stackings (as code lists) whose total discount = D.
+(define
+  stacking-by-totalo
+  (fn
+    (stackings codes total)
+    (fresh
+      (st)
+      (membero st stackings)
+      (project
+        (st)
+        (mk-conj
+          (== codes (stacking-codes st))
+          (== total (stacking-total st)))))))
+
+;; --- top-level entry: best discount for a cart under a ruleset ---
+
+(define
+  best-promo-discount
+  (fn
+    (ctx cart ruleset exclusions)
+    (best-discount exclusions (applicable-promos ctx cart ruleset))))
+
+(define
+  best-promo-codes
+  (fn
+    (ctx cart ruleset exclusions)
+    (best-codes exclusions (applicable-promos ctx cart ruleset))))

lib/commerce/stock.sx

@@ -0,0 +1,106 @@
+;; lib/commerce/stock.sx — stock-constrained reservation.
+;;
+;; Reservation is a precondition the host checks BEFORE order-begin! (validate →
+;; begin), so the order flow stays pure orchestration. Availability is read
+;; relationally from the catalog stock facts (catalog.sx stocko); a stock view
+;; subtracts already-reserved quantities so concurrent orders can't over-reserve.
+;;
+;;   can-reserve? cat cart                  — every line fits available stock
+;;   reservation-shortfalls cat cart        — the lines that do not, with detail
+;;   effective-available cat reservations …  — availability net of reservations
+;;   sufficient-stocko cat sku variant qty  — relational "can supply qty?" query
+
+;; Deterministic on-hand stock for a (sku,variant); 0 if absent.
+(define
+  available-stock
+  (fn
+    (cat sku variant)
+    (let
+      ((rs (run 1 q (stocko cat sku variant q))))
+      (if (empty? rs) 0 (first rs)))))
+
+;; Units a line cannot fulfil from on-hand stock (0 if it fits).
+(define
+  line-shortfall
+  (fn
+    (cat line)
+    (let
+      ((short (- (line-qty line) (available-stock cat (line-sku line) (line-variant line)))))
+      (if (< short 0) 0 short))))
+
+(define
+  line-reservable?
+  (fn (cat line) (= (line-shortfall cat line) 0)))
+
+;; Lines that cannot be fully reserved, each with requested/available/short.
+(define
+  reservation-shortfalls
+  (fn
+    (cat cart)
+    (reduce
+      (fn
+        (acc line)
+        (let
+          ((short (line-shortfall cat line)))
+          (if (> short 0) (append acc (list {:requested (line-qty line) :available (available-stock cat (line-sku line) (line-variant line)) :sku (line-sku line) :variant (line-variant line) :short short})) acc)))
+      (list)
+      cart)))
+
+(define
+  can-reserve?
+  (fn (cat cart) (empty? (reservation-shortfalls cat cart))))
+
+;; Validate → reject; the host gates order-begin! on this.
+(define
+  reserve-check
+  (fn (cat cart) (if (can-reserve? cat cart) :ok {:shortfalls (reservation-shortfalls cat cart) :rejected :insufficient-stock})))
+
+;; --- reservation view (concurrent-safety) ---
+;; reservations: list of (sku variant qty) already held.
+
+(define
+  reserved-qty
+  (fn
+    (reservations sku variant)
+    (reduce
+      (fn
+        (acc r)
+        (if
+          (and (= (first r) sku) (= (nth r 1) variant))
+          (+ acc (nth r 2))
+          acc))
+      0
+      reservations)))
+
+;; On-hand minus already-reserved (clamped at 0).
+(define
+  effective-available
+  (fn
+    (cat reservations sku variant)
+    (let
+      ((eff (- (available-stock cat sku variant) (reserved-qty reservations sku variant))))
+      (if (< eff 0) 0 eff))))
+
+;; Can a line be reserved given existing reservations?
+(define
+  line-reservable-with?
+  (fn
+    (cat reservations line)
+    (<=
+      (line-qty line)
+      (effective-available
+        cat
+        reservations
+        (line-sku line)
+        (line-variant line)))))
+
+;; --- relational availability query (the showcase) ---
+
+;; Succeeds when on-hand stock for (sku,variant) covers qty. Multidirectional
+;; over the stock facts: "which variants of widget can supply 5?" is a backward
+;; query.
+(define
+  sufficient-stocko
+  (fn
+    (cat sku variant qty)
+    (fresh (avail) (stocko cat sku variant avail) (lteo-i qty avail))))

lib/commerce/tests/api.sx

@@ -0,0 +1,73 @@
+;; lib/commerce/tests/api.sx — public commerce session surface.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  acat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated))
+    (list (list "widget" :small -200))
+    (list)))
+
+(define
+  arules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :zero-rated :guest 0)))
+
+(define actx (make-pricing-context acat arules :uk :guest))
+(define sess0 (commerce-session actx))
+
+;; --- empty session ---
+
+(commerce-test "new-session-empty" (commerce-cart sess0) empty-cart)
+(commerce-test "new-count" (commerce-count sess0) 0)
+(commerce-test "new-total" (commerce-total sess0) {:subtotal 0 :discounts 0 :total 0 :tax 0})
+
+;; --- add + total ---
+
+(define
+  sess1
+  (commerce-add
+    (commerce-add sess0 "widget" :small 2)
+    "book"
+    :none 1))
+
+(commerce-test "add-count" (commerce-count sess1) 3)
+(commerce-test
+  "add-lines"
+  (commerce-lines sess1)
+  (list (list "widget" :small 2) (list "book" :none 1)))
+(commerce-test "add-total" (commerce-total sess1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
+
+;; --- mutate ---
+
+(commerce-test
+  "set-qty"
+  (commerce-lines (commerce-set-qty sess1 "widget" :small 1))
+  (list (list "widget" :small 1) (list "book" :none 1)))
+
+(commerce-test
+  "remove"
+  (commerce-lines (commerce-remove sess1 "book" :none))
+  (list (list "widget" :small 2)))
+
+;; --- validation ---
+
+(commerce-test "can-add-yes" (commerce-can-add? sess0 "widget") true)
+(commerce-test "can-add-no" (commerce-can-add? sess0 "ghost") false)
+
+;; --- audit breakdown ---
+
+(commerce-test
+  "explain"
+  (commerce-explain sess1)
+  (list {:sku "widget" :unit 800 :qty 2 :variant :small :extended 1600 :tax 320} {:sku "book" :unit 800 :qty 1 :variant :none :extended 800 :tax 0}))
+
+;; --- checkout stub ---
+
+(commerce-test
+  "checkout-stub"
+  (get (commerce-checkout sess1) :status)
+  :not-implemented)

lib/commerce/tests/attribution.sx

@@ -0,0 +1,124 @@
+;; lib/commerce/tests/attribution.sx — line-level discount attribution.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "gizmo" 2000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define gctx (make-pricing-context pcat (list) :uk :guest))
+(define mctx (make-pricing-context pcat (list) :uk :member))
+
+(define
+  cart
+  (list
+    (list "widget" :none 2)
+    (list "gizmo" :none 1)
+    (list "book" :none 1)
+    (list "tea" :none 6)))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :percent "TWENTY" :standard 2000)
+    (list :bundle "B3T" "tea" 3)
+    (list :fixed "FIVE" 0 500)
+    (list :member "MEM" :standard 1500)))
+
+(define w-line (list "widget" :none 2))
+(define t-line (list "tea" :none 6))
+(define bk-line (list "book" :none 1))
+
+;; --- scope helpers ---
+
+(commerce-test
+  "class-lines-standard"
+  (class-lines gctx cart :standard)
+  (list (list "widget" :none 2) (list "gizmo" :none 1)))
+
+(commerce-test
+  "promo-lines-bundle"
+  (promo-lines gctx cart (list :bundle "B3T" "tea" 3))
+  (list (list "tea" :none 6)))
+
+(commerce-test
+  "promo-lines-fixed-none"
+  (promo-lines gctx cart (list :fixed "FIVE" 0 500))
+  (list))
+
+;; --- forward: which lines does a code touch? ---
+
+(commerce-test
+  "lines-for-ten"
+  (lines-for-code gctx cart ruleset "TEN")
+  (list (list "widget" :none 2) (list "gizmo" :none 1)))
+
+(commerce-test
+  "lines-for-bundle"
+  (lines-for-code gctx cart ruleset "B3T")
+  (list (list "tea" :none 6)))
+
+(commerce-test
+  "lines-for-fixed-empty"
+  (lines-for-code gctx cart ruleset "FIVE")
+  (list))
+(commerce-test
+  "lines-for-mem-guest-empty"
+  (lines-for-code gctx cart ruleset "MEM")
+  (list))
+
+;; --- backward: which codes touch this line? (the showcase) ---
+
+(commerce-test
+  "codes-for-widget-guest"
+  (codes-for-line gctx cart ruleset w-line)
+  (list "TEN" "TWENTY"))
+
+(commerce-test
+  "codes-for-tea"
+  (codes-for-line gctx cart ruleset t-line)
+  (list "B3T"))
+(commerce-test
+  "codes-for-book-none"
+  (codes-for-line gctx cart ruleset bk-line)
+  (list))
+
+;; member sees the member rate too
+(commerce-test
+  "codes-for-widget-member"
+  (codes-for-line mctx cart ruleset w-line)
+  (list "TEN" "TWENTY" "MEM"))
+
+(commerce-test
+  "lines-for-mem-member"
+  (lines-for-code mctx cart ruleset "MEM")
+  (list (list "widget" :none 2) (list "gizmo" :none 1)))
+
+;; --- predicate ---
+
+(commerce-test
+  "touched-yes"
+  (line-touched-by? gctx cart ruleset "TEN" w-line)
+  true)
+(commerce-test
+  "touched-no-wrong-class"
+  (line-touched-by? gctx cart ruleset "B3T" w-line)
+  false)
+(commerce-test
+  "touched-no-guest-mem"
+  (line-touched-by? gctx cart ruleset "MEM" w-line)
+  false)
+
+;; --- order-level (fixed) codes ---
+
+(commerce-test
+  "order-level"
+  (order-level-codes gctx cart ruleset)
+  (list "FIVE"))

lib/commerce/tests/cart.sx

@@ -0,0 +1,103 @@
+;; lib/commerce/tests/cart.sx — cart structure + line operations.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+;; --- add ---
+
+(commerce-test
+  "add-to-empty"
+  (cart-add empty-cart "widget" :small 2)
+  (list (list "widget" :small 2)))
+
+(commerce-test
+  "add-merges-same-line"
+  (cart-add
+    (cart-add empty-cart "widget" :small 2)
+    "widget"
+    :small 3)
+  (list (list "widget" :small 5)))
+
+(commerce-test
+  "add-different-variant-separate"
+  (cart-add
+    (cart-add empty-cart "widget" :small 2)
+    "widget"
+    :large 1)
+  (list (list "widget" :small 2) (list "widget" :large 1)))
+
+(commerce-test
+  "add-different-sku-separate"
+  (cart-add
+    (cart-add empty-cart "widget" :small 2)
+    "gadget"
+    :std 1)
+  (list (list "widget" :small 2) (list "gadget" :std 1)))
+
+(commerce-test
+  "add-preserves-order"
+  (cart-skus
+    (cart-add
+      (cart-add (cart-add empty-cart "a" :v 1) "b" :v 1)
+      "c"
+      :v 1))
+  (list "a" "b" "c"))
+
+;; --- qty queries ---
+
+(define
+  c2
+  (cart-add
+    (cart-add empty-cart "widget" :small 2)
+    "gadget"
+    :std 4))
+
+(commerce-test "cart-qty-found" (cart-qty c2 "widget" :small) 2)
+(commerce-test "cart-qty-missing" (cart-qty c2 "widget" :large) 0)
+(commerce-test "cart-count" (cart-count c2) 6)
+(commerce-test "cart-empty-yes" (cart-empty? empty-cart) true)
+(commerce-test "cart-empty-no" (cart-empty? c2) false)
+
+;; --- set-qty ---
+
+(commerce-test
+  "set-qty-existing"
+  (cart-set-qty c2 "widget" :small 10)
+  (list (list "widget" :small 10) (list "gadget" :std 4)))
+
+(commerce-test
+  "set-qty-new-line"
+  (cart-set-qty empty-cart "book" :std 3)
+  (list (list "book" :std 3)))
+
+(commerce-test
+  "set-qty-zero-removes"
+  (cart-set-qty c2 "widget" :small 0)
+  (list (list "gadget" :std 4)))
+
+;; --- remove ---
+
+(commerce-test
+  "remove-line"
+  (cart-remove c2 "gadget" :std)
+  (list (list "widget" :small 2)))
+
+(commerce-test
+  "remove-missing-noop"
+  (cart-remove c2 "nope" :std)
+  (list (list "widget" :small 2) (list "gadget" :std 4)))
+
+;; --- relational view ---
+
+(commerce-test
+  "cart-lineo-forward"
+  (run* q (cart-lineo c2 "gadget" :std q))
+  (list 4))
+
+(commerce-test
+  "cart-lineo-sku-by-qty-backward"
+  (run* sk (fresh (v) (cart-lineo c2 sk v 4)))
+  (list "gadget"))
+
+(commerce-test
+  "cart-lineo-all-skus"
+  (run* sk (fresh (v q) (cart-lineo c2 sk v q)))
+  (list "widget" "gadget"))

lib/commerce/tests/catalog.sx

@@ -0,0 +1,93 @@
+;; lib/commerce/tests/catalog.sx — catalog facts + relational accessors.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;; Query vars avoid the name `s` (the run-n macro binds `s` internally).
+
+(define
+  cat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "gadget" 2500 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list
+      (list "widget" :small -200)
+      (list "widget" :large 500)
+      (list "gadget" :std 0))
+    (list
+      (list "widget" :small 5)
+      (list "widget" :large 0)
+      (list "gadget" :std 12))))
+
+;; --- forward lookups ---
+
+(commerce-test
+  "price-forward"
+  (run* p (priceo cat "widget" p))
+  (list 1000))
+(commerce-test
+  "class-forward"
+  (run* c (classo cat "book" c))
+  (list :zero-rated))
+(commerce-test
+  "product-forward"
+  (run* q (fresh (p c) (producto cat "gadget" p c) (== q (list p c))))
+  (list (list 2500 :standard)))
+
+;; --- backward lookups (the showcase) ---
+
+(commerce-test
+  "sku-by-price-backward"
+  (run* sk (priceo cat sk 1000))
+  (list "widget" "tea"))
+
+(commerce-test
+  "sku-by-class-backward"
+  (run* sk (classo cat sk :standard))
+  (list "widget" "gadget"))
+
+(commerce-test
+  "all-prices"
+  (run* p (fresh (sk) (priceo cat sk p)))
+  (list 1000 2500 800 1000))
+
+;; --- variants + effective unit price ---
+
+(commerce-test
+  "variant-delta-forward"
+  (run* d (varianto cat "widget" :small d))
+  (list -200))
+
+(commerce-test
+  "unit-price-small"
+  (run* p (unit-priceo cat "widget" :small p))
+  (list 800))
+
+(commerce-test
+  "unit-price-large"
+  (run* p (unit-priceo cat "widget" :large p))
+  (list 1500))
+
+(commerce-test
+  "variant-by-delta-backward"
+  (run* v (varianto cat "widget" v -200))
+  (list :small))
+
+;; --- stock ---
+
+(commerce-test
+  "stock-forward"
+  (run* q (stocko cat "widget" :small q))
+  (list 5))
+
+(commerce-test
+  "in-stock-skus-backward"
+  (run* sk (fresh (v q) (stocko cat sk v q) (lto-i 0 q)))
+  (list "widget" "gadget"))
+
+;; --- deterministic helpers ---
+
+(commerce-test "catalog-price-helper" (catalog-price cat "gadget") 2500)
+(commerce-test "catalog-class-helper" (catalog-class cat "tea") :reduced)
+(commerce-test "catalog-has-yes" (catalog-has? cat "book") true)
+(commerce-test "catalog-has-no" (catalog-has? cat "nonesuch") false)

lib/commerce/tests/federation.sx

@@ -0,0 +1,88 @@
+;; lib/commerce/tests/federation.sx — federated catalog (out-of-scope stub).
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  cat-a
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated))
+    (list)
+    (list)))
+
+(define
+  cat-b
+  (make-catalog
+    (list
+      (list "widget" 900 :standard)
+      (list "tea" 1200 :reduced))
+    (list)
+    (list)))
+
+(define
+  cat-c
+  (make-catalog (list (list "widget" 1100 :standard)) (list) (list)))
+
+(define
+  fed
+  (federation-add
+    (federation-add (make-federation :alpha cat-a) :beta cat-b)
+    :gamma cat-c))
+
+;; --- structure ---
+
+(commerce-test "is-stub" federation-stub? true)
+(commerce-test
+  "instances"
+  (federation-instances fed)
+  (list :alpha :beta :gamma))
+(commerce-test "product-count" (len (fed-products fed)) 5)
+
+;; --- forward query ---
+
+(commerce-test
+  "price-at-instance"
+  (run* p (fed-priceo fed :beta "widget" p))
+  (list 900))
+
+;; --- backward queries (the showcase) ---
+
+(commerce-test
+  "instances-with-widget"
+  (instances-with-sku fed "widget")
+  (list :alpha :beta :gamma))
+
+(commerce-test
+  "instances-with-book"
+  (instances-with-sku fed "book")
+  (list :alpha))
+
+(commerce-test
+  "instances-with-tea"
+  (instances-with-sku fed "tea")
+  (list :beta))
+
+(commerce-test
+  "instance-by-price-backward"
+  (run* inst (fresh (c) (fed-producto fed inst "widget" 1100 c)))
+  (list :gamma))
+
+;; --- offers + cheapest (deterministic selection) ---
+
+(commerce-test
+  "widget-offers"
+  (sku-offers fed "widget")
+  (list
+    (list 1000 :alpha)
+    (list 900 :beta)
+    (list 1100 :gamma)))
+
+(commerce-test
+  "cheapest-widget"
+  (cheapest-offer fed "widget")
+  (list 900 :beta))
+(commerce-test
+  "cheapest-book"
+  (cheapest-offer fed "book")
+  (list 800 :alpha))
+(commerce-test "cheapest-missing" (cheapest-offer fed "ghost") nil)

lib/commerce/tests/integration.sx

@@ -0,0 +1,104 @@
+;; lib/commerce/tests/integration.sx — end-to-end composition proof.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;;
+;; One narrative across every module: catalog → stock check → quote
+;; (promo+stack+tax) → order flow → payment envelope → settle → recon → refund.
+;; Proves the seams tie together with consistent numbers (the project's thesis:
+;; minikanren pricing + flow lifecycle + persist ledger compose).
+;; Builds one flow env with BOTH the order and refund flows.
+
+(define env (order-make-env))
+(define _rf (refund-flow-load! env))
+(define b (persist/mem-backend))
+
+(define
+  cat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated))
+    (list (list "widget" :small -200))
+    (list (list "widget" :small 10) (list "book" :none 5))))
+
+(define
+  rules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :zero-rated :guest 0)))
+
+(define ctx (make-pricing-context cat rules :uk :guest))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :fixed "FIVE" 0 50)))
+
+;; widget :small x2 → unit 800, extended 1600 (standard); book x1 → 800 (zero-rated)
+(define
+  cart
+  (list (list "widget" :small 2) (list "book" :none 1)))
+
+;; 1. stock gating passes (widget:small 10 >= 2)
+(commerce-test "int-can-reserve" (can-reserve? cat cart) true)
+
+;; 2. quote ties the whole pricing pipeline together
+;;    subtotal 2400; discount TEN 160 + FIVE 50 = 210; tax 1600@20% = 320;
+;;    total 2400 - 210 + 320 = 2510
+(define q (cart-quote ctx cart ruleset (list)))
+(commerce-test "int-quote-subtotal" (quote-subtotal q) 2400)
+(commerce-test "int-quote-discount" (quote-discount q) 210)
+(commerce-test "int-quote-tax" (quote-tax q) 320)
+(commerce-test "int-quote-total" (quote-total q) 2510)
+
+;; 3. attribution explains where the discount landed
+(commerce-test
+  "int-attribution"
+  (codes-for-line ctx cart ruleset (list "widget" :small 2))
+  (list "TEN"))
+(commerce-test
+  "int-order-level"
+  (order-level-codes ctx cart ruleset)
+  (list "FIVE"))
+
+;; 4. order carries the quote total into the ledger; suspends at payment
+(define oid "INT-1")
+(define id (order-begin! env b oid 1000 q))
+(commerce-test "int-order-total-from-quote" (order-total b oid) 2510)
+(commerce-test "int-waiting-payment" (order-flow-waiting env id) "payment")
+
+;; 5. the payment envelope reflects the quoted total
+(commerce-test
+  "int-payment-envelope"
+  (payment-request b oid :GBP "https://shop/return")
+  {:order "INT-1" :amount 2510 :return-url "https://shop/return" :currency :GBP})
+
+;; 6. settle the quoted amount → reconciles exactly
+(commerce-test
+  "int-settled"
+  (order-settle! env b id oid "pay-int" 1002 2510)
+  :settled)
+(commerce-test "int-status-fulfilled" (order-status b oid) :fulfilled)
+(commerce-test "int-recon-ok" (order-recon b oid) :ok)
+
+;; 7. partial refund via its own flow → recon moves to underpaid
+(define rid (refund-begin! env b oid "rf-int" 2000 510))
+(commerce-test "int-refund-approve" (refund-approve! env rid) :approved)
+(commerce-test
+  "int-refund-settle"
+  (refund-settle! env b rid oid "rf-int" 2001 510)
+  :settled)
+(commerce-test
+  "int-refunded-amount"
+  (order-refunded-amount-of (order-events b oid))
+  510)
+(commerce-test "int-recon-after-refund" (order-recon b oid) :underpaid)
+
+;; 8. ledger reconciliation flags the now-mismatched order
+(commerce-test
+  "int-mismatch"
+  (mismatched-orders b)
+  (list (order-stream "INT-1")))
+
+;; 9. distinct flow ids for the order and the refund
+(commerce-test "int-distinct-flow-ids" (not (= id rid)) true)

lib/commerce/tests/ledger.sx

@@ -0,0 +1,80 @@
+;; lib/commerce/tests/ledger.sx — order ledger on persist + idempotent recon.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+
+;; --- lifecycle status projection ---
+
+(define b1 (persist/mem-backend))
+(define _c1 (order-create b1 "A1" 100 q1))
+(commerce-test "status-pending" (order-status b1 "A1") :pending)
+(define _r1 (order-reserve b1 "A1" 101 {:lines 2}))
+(commerce-test "status-reserved" (order-status b1 "A1") :reserved)
+(define _p1 (order-pay b1 "A1" "ref-1" 102 1200))
+(commerce-test "status-paid" (order-status b1 "A1") :paid)
+(define _f1 (order-fulfil b1 "A1" 103 {:carrier "post"}))
+(commerce-test "status-fulfilled" (order-status b1 "A1") :fulfilled)
+
+(commerce-test "total-projection" (order-total b1 "A1") 1200)
+(commerce-test "paid-projection" (order-paid b1 "A1") 1200)
+(commerce-test "recon-ok" (order-recon b1 "A1") :ok)
+(commerce-test "event-count" (len (order-events b1 "A1")) 4)
+
+;; --- idempotency: replayed webhook does not double-record ---
+
+(define b2 (persist/mem-backend))
+(define _c2 (order-create b2 "B1" 200 q1))
+(define _p2a (order-pay b2 "B1" "sumup-9" 201 1200))
+(define _p2b (order-pay b2 "B1" "sumup-9" 201 1200))
+(define _p2c (order-pay b2 "B1" "sumup-9" 201 1200))
+
+(commerce-test "idem-single-event" (len (order-events b2 "B1")) 2)
+(commerce-test "idem-paid-once" (order-paid b2 "B1") 1200)
+(commerce-test "idem-recon-ok" (order-recon b2 "B1") :ok)
+(commerce-test "idem-same-event" (= _p2a _p2c) true)
+
+;; --- mismatch detection ---
+
+(define bun (persist/mem-backend))
+(define _cu (order-create bun "U1" 300 q1))
+(commerce-test "unpaid-recon" (order-recon bun "U1") :unpaid)
+
+(define bup (persist/mem-backend))
+(define _cp (order-create bup "U2" 300 q1))
+(define _pp1 (order-pay bup "U2" "r-a" 301 1200))
+(define _pp2 (order-pay bup "U2" "r-b" 302 1200))
+(commerce-test "double-charge-overpaid" (order-recon bup "U2") :overpaid)
+(commerce-test "double-charge-amount" (order-paid bup "U2") 2400)
+
+(define bsh (persist/mem-backend))
+(define _cs (order-create bsh "U3" 400 q1))
+(define _ps (order-pay bsh "U3" "r-short" 401 1000))
+(commerce-test "underpaid-recon" (order-recon bsh "U3") :underpaid)
+
+;; --- refund (idempotent) reduces net ---
+
+(define brf (persist/mem-backend))
+(define _crf (order-create brf "R1" 500 q1))
+(define _prf (order-pay brf "R1" "p-1" 501 1200))
+(define _rf1 (order-refund brf "R1" "rf-1" 502 200))
+(define _rf2 (order-refund brf "R1" "rf-1" 502 200))
+(commerce-test "refund-idem-net" (order-recon brf "R1") :underpaid)
+(commerce-test "refund-idem-events" (len (order-events brf "R1")) 3)
+
+;; --- cross-ledger reconciliation ---
+
+(define bL (persist/mem-backend))
+(define _l1 (order-create bL "OK1" 600 q1))
+(define _l1p (order-pay bL "OK1" "ok-ref" 601 1200))
+(define _l2 (order-create bL "OVER1" 600 q1))
+(define _l2a (order-pay bL "OVER1" "o-a" 602 1200))
+(define _l2b (order-pay bL "OVER1" "o-b" 603 1200))
+(define _l3 (order-create bL "UNDER1" 600 q1))
+(define _l3p (order-pay bL "UNDER1" "u-ref" 604 900))
+(define _l4 (order-create bL "PENDING1" 600 q1))
+
+(commerce-test "ledger-order-count" (len (order-ids bL)) 4)
+(commerce-test
+  "ledger-mismatches"
+  (sort (ledger-mismatches bL))
+  (sort (list (order-stream "OVER1") (order-stream "UNDER1"))))

lib/commerce/tests/nettax.sx

@@ -0,0 +1,92 @@
+;; lib/commerce/tests/nettax.sx — discount-aware (net) tax policy.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define
+  rules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :reduced :guest 500)))
+
+(define gctx (make-pricing-context pcat rules :uk :guest))
+
+;; widget x3 = 3000 (standard), tea x6 = 6000 (reduced); subtotal 9000
+(define
+  cart
+  (list (list "widget" :none 3) (list "tea" :none 6)))
+
+(define ruleset (list (list :percent "TEN" :standard 1000)))
+
+;; --- allocation: proportional, sums exactly to the discount ---
+
+(commerce-test
+  "allocate-even"
+  (allocate-discount pcat cart 300)
+  (list 100 200))
+(commerce-test
+  "allocate-sums-to-discount"
+  (ct-sum (allocate-discount pcat cart 300))
+  300)
+
+;; remainder distribution: 100 over (3000,6000)/9000 = (33,66) rem 1 -> (34,66)
+(commerce-test
+  "allocate-remainder"
+  (allocate-discount pcat cart 100)
+  (list 34 66))
+(commerce-test
+  "allocate-remainder-sums"
+  (ct-sum (allocate-discount pcat cart 100))
+  100)
+
+(commerce-test
+  "allocate-zero"
+  (allocate-discount pcat cart 0)
+  (list 0 0))
+(commerce-test
+  "allocate-empty"
+  (allocate-discount pcat empty-cart 0)
+  (list))
+
+;; --- net tax vs gross tax ---
+;; discount = TEN 10% of standard 3000 = 300, allocated (100 200).
+;; net: widget 2900@20%=580, tea 5800@5%=290 -> net tax 870 (gross was 900).
+
+(commerce-test
+  "net-quote"
+  (cart-quote-net gctx cart ruleset (list))
+  {:codes (list "TEN") :subtotal 9000 :discount 300 :total 9570 :tax 870})
+
+;; same cart through the gross policy taxes 900 (the documented default)
+(commerce-test
+  "gross-quote-for-contrast"
+  (quote-tax (cart-quote gctx cart ruleset (list)))
+  900)
+
+(commerce-test
+  "net-tax-lower"
+  (quote-tax (cart-quote-net gctx cart ruleset (list)))
+  870)
+
+;; --- no discount: net policy == gross policy ---
+
+(commerce-test
+  "no-discount-net-equals-gross"
+  (=
+    (cart-quote-net gctx cart (list) (list))
+    (cart-quote gctx cart (list) (list)))
+  true)
+
+;; --- empty cart ---
+
+(commerce-test
+  "net-empty"
+  (cart-quote-net gctx empty-cart ruleset (list))
+  {:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})

lib/commerce/tests/order.sx

@@ -0,0 +1,74 @@
+;; lib/commerce/tests/order.sx — order lifecycle as a flow-on-sx flow.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;; Builds the (expensive) flow env once; all assertions share it.
+
+(define env (order-make-env))
+(define b (persist/mem-backend))
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+
+;; --- happy path: begin suspends at payment ---
+
+(define id1 (order-begin! env b "O1" 100 q1))
+
+(commerce-test "begin-status-reserved" (order-status b "O1") :reserved)
+(commerce-test "begin-waiting-payment" (order-flow-waiting env id1) "payment")
+(commerce-test "begin-not-yet-paid" (order-paid b "O1") 0)
+
+;; --- settle: payment webhook drives fulfilment ---
+
+(define s1 (order-settle! env b id1 "O1" "ref-1" 102 1200))
+
+(commerce-test "settle-result" s1 :settled)
+(commerce-test "settle-status-fulfilled" (order-status b "O1") :fulfilled)
+(commerce-test "settle-flow-done" (order-flow-status env id1) "done")
+(commerce-test "settle-recon-ok" (order-recon b "O1") :ok)
+(commerce-test "settle-event-count" (len (order-events b "O1")) 4)
+
+;; --- webhook replay: a second settle is a no-op ---
+
+(define s1b (order-settle! env b id1 "O1" "ref-1" 102 1200))
+
+(commerce-test "replay-already-settled" s1b :already-settled)
+(commerce-test
+  "replay-no-extra-events"
+  (len (order-events b "O1"))
+  4)
+(commerce-test "replay-recon-still-ok" (order-recon b "O1") :ok)
+
+;; --- a second order gets its own flow id and suspends independently ---
+
+(define id2 (order-begin! env b "O2" 200 q1))
+
+(commerce-test "second-distinct-id" (not (= id1 id2)) true)
+(commerce-test
+  "second-waiting-payment"
+  (order-flow-waiting env id2)
+  "payment")
+(commerce-test "first-unaffected" (order-status b "O1") :fulfilled)
+
+;; --- durability: a suspended order survives a process restart ---
+
+(define id3 (order-begin! env b "O3" 300 q1))
+(commerce-test "pre-restart-waiting" (order-flow-waiting env id3) "payment")
+
+(define _restart (order-flow-restart! env))
+
+(commerce-test
+  "post-restart-still-waiting"
+  (order-flow-waiting env id3)
+  "payment")
+(commerce-test "post-restart-ledger-intact" (order-status b "O3") :reserved)
+
+(define s3 (order-settle! env b id3 "O3" "ref-3" 302 1200))
+
+(commerce-test "post-restart-settled" s3 :settled)
+(commerce-test "post-restart-status" (order-status b "O3") :fulfilled)
+(commerce-test "post-restart-recon-ok" (order-recon b "O3") :ok)
+(commerce-test "post-restart-flow-done" (order-flow-status env id3) "done")
+
+;; --- payment-request envelope (provider-neutral) for the still-suspended O2 ---
+
+(commerce-test
+  "pending-payments-lists-suspended"
+  (pending-payments env b :GBP "https://shop/return")
+  (list {:id id2 :request {:order "O2" :amount 1200 :return-url "https://shop/return" :currency :GBP}}))

lib/commerce/tests/payment.sx

@@ -0,0 +1,43 @@
+;; lib/commerce/tests/payment.sx — provider-neutral payment-request envelope.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;; Envelope construction is ledger-only (no flow env); pending-payments (which
+;; needs the flow env) is exercised in the order suite.
+
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+(define q2 {:codes (list) :subtotal 5000 :discount 500 :total 4500 :tax 0})
+
+(define b (persist/mem-backend))
+(define _c1 (order-create b "P1" 1 q1))
+(define _c2 (order-create b "P2" 1 q2))
+
+(commerce-test
+  "envelope"
+  (payment-request b "P1" :GBP "https://shop/return")
+  {:order "P1" :amount 1200 :return-url "https://shop/return" :currency :GBP})
+
+(commerce-test
+  "envelope-amount"
+  (payment-request-amount (payment-request b "P1" :GBP "x"))
+  1200)
+(commerce-test
+  "envelope-currency"
+  (payment-request-currency (payment-request b "P1" :GBP "x"))
+  :GBP)
+(commerce-test
+  "envelope-order"
+  (payment-request-order (payment-request b "P1" :GBP "x"))
+  "P1")
+(commerce-test
+  "envelope-return-url"
+  (payment-request-return-url (payment-request b "P1" :GBP "https://r"))
+  "https://r")
+
+;; amount tracks the ledger total, currency is per-call (provider/instance config)
+(commerce-test
+  "envelope-amount-2"
+  (payment-request-amount (payment-request b "P2" :EUR "x"))
+  4500)
+(commerce-test
+  "envelope-currency-2"
+  (payment-request-currency (payment-request b "P2" :EUR "x"))
+  :EUR)

lib/commerce/tests/price.sx

@@ -0,0 +1,100 @@
+;; lib/commerce/tests/price.sx — subtotal + jurisdiction-relational tax.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list
+      (list "widget" :small -200)
+      (list "widget" :large 500))
+    (list)))
+
+(define
+  rules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :reduced :guest 500)
+    (list :uk :zero-rated :guest 0)
+    (list :uk :standard :member 1000)
+    (list :ie :standard :guest 2300)))
+
+(define gctx (make-pricing-context pcat rules :uk :guest))
+(define mctx (make-pricing-context pcat rules :uk :member))
+
+;; --- unit + line pricing ---
+
+(commerce-test
+  "unit-price-variant"
+  (line-unit-price pcat "widget" :small)
+  800)
+(commerce-test
+  "unit-price-no-variant"
+  (line-unit-price pcat "widget" :none)
+  1000)
+(commerce-test "unit-price-unknown" (line-unit-price pcat "ghost" :none) nil)
+(commerce-test
+  "line-extended"
+  (line-extended pcat (list "widget" :small 2))
+  1600)
+
+;; --- subtotal ---
+
+(define
+  cart1
+  (list (list "widget" :small 2) (list "book" :none 1)))
+
+(commerce-test "subtotal" (cart-subtotal pcat cart1) 2400)
+(commerce-test "subtotal-empty" (cart-subtotal pcat empty-cart) 0)
+
+;; --- tax rate lookup (relational, both directions) ---
+
+(commerce-test
+  "rate-forward"
+  (rate-bps rules :uk :standard :guest)
+  2000)
+(commerce-test
+  "rate-missing"
+  (rate-bps rules :fr :standard :guest)
+  0)
+(commerce-test
+  "rate-juris-by-bps-backward"
+  (run* j (fresh (cust) (taxo rules j :standard cust 2300)))
+  (list :ie))
+(commerce-test
+  "rate-customer-by-bps-backward"
+  (run* cust (taxo rules :uk :standard cust 1000))
+  (list :member))
+
+;; --- apply-bps rounding (half up, integer only) ---
+
+(commerce-test "bps-exact" (apply-bps 1600 2000) 320)
+(commerce-test "bps-round-up" (apply-bps 799 2000) 160)
+(commerce-test "bps-zero" (apply-bps 800 0) 0)
+
+;; --- line + cart tax ---
+
+(commerce-test
+  "line-tax-standard"
+  (line-tax gctx (list "widget" :small 2))
+  320)
+(commerce-test
+  "line-tax-zero-rated"
+  (line-tax gctx (list "book" :none 1))
+  0)
+(commerce-test
+  "line-tax-member"
+  (line-tax mctx (list "widget" :small 2))
+  160)
+(commerce-test "cart-tax-guest" (cart-tax gctx cart1) 320)
+
+;; --- total dict (deterministic) ---
+
+(commerce-test "total-guest" (cart-total gctx cart1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
+
+(commerce-test "total-member" (cart-total mctx cart1) {:subtotal 2400 :discounts 0 :total 2560 :tax 160})
+
+(commerce-test "total-empty" (cart-total gctx empty-cart) {:subtotal 0 :discounts 0 :total 0 :tax 0})

lib/commerce/tests/promo.sx

@@ -0,0 +1,142 @@
+;; lib/commerce/tests/promo.sx — promo rules + relational enumeration.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define gctx (make-pricing-context pcat (list) :uk :guest))
+(define mctx (make-pricing-context pcat (list) :uk :member))
+
+(define
+  cart
+  (list
+    (list "widget" :none 3)
+    (list "book" :none 1)
+    (list "tea" :none 6)))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :fixed "FIVER" 5000 500)
+    (list :bundle "B3T" "tea" 3)
+    (list :member "MEM" :standard 1500)))
+
+;; --- per-type amounts ---
+
+(commerce-test
+  "percent-amount"
+  (promo-amount gctx cart (list :percent "TEN" :standard 1000))
+  300)
+
+(commerce-test
+  "fixed-amount-met"
+  (promo-amount gctx cart (list :fixed "FIVER" 5000 500))
+  500)
+
+(commerce-test
+  "fixed-amount-not-met"
+  (promo-amount
+    gctx
+    (list (list "widget" :none 1))
+    (list :fixed "FIVER" 5000 500))
+  0)
+
+(commerce-test
+  "fixed-amount-capped"
+  (promo-amount
+    gctx
+    (list (list "book" :none 1))
+    (list :fixed "BIG" 0 9999))
+  800)
+
+(commerce-test
+  "bundle-amount"
+  (promo-amount gctx cart (list :bundle "B3T" "tea" 3))
+  2000)
+
+(commerce-test
+  "member-amount-guest"
+  (promo-amount gctx cart (list :member "MEM" :standard 1500))
+  0)
+
+(commerce-test
+  "member-amount-member"
+  (promo-amount mctx cart (list :member "MEM" :standard 1500))
+  450)
+
+;; --- relational enumeration: forward ---
+
+(commerce-test
+  "discounto-all-guest"
+  (run*
+    pair
+    (fresh
+      (code amount)
+      (promo-discounto gctx cart ruleset code amount)
+      (== pair (list code amount))))
+  (list
+    (list "TEN" 300)
+    (list "FIVER" 500)
+    (list "B3T" 2000)
+    (list "MEM" 0)))
+
+(commerce-test
+  "applicable-guest"
+  (applicable-promos gctx cart ruleset)
+  (list
+    (list "TEN" 300)
+    (list "FIVER" 500)
+    (list "B3T" 2000)))
+
+(commerce-test
+  "applicable-member"
+  (applicable-promos mctx cart ruleset)
+  (list
+    (list "TEN" 300)
+    (list "FIVER" 500)
+    (list "B3T" 2000)
+    (list "MEM" 450)))
+
+;; --- relational enumeration: backward (the showcase) ---
+
+(commerce-test
+  "code-by-discount-2000"
+  (run* code (promo-applieso gctx cart ruleset code 2000))
+  (list "B3T"))
+
+(commerce-test
+  "code-by-discount-500"
+  (run* code (promo-applieso gctx cart ruleset code 500))
+  (list "FIVER"))
+
+(commerce-test
+  "code-by-discount-none"
+  (run* code (promo-applieso gctx cart ruleset code 9999))
+  (list))
+
+;; --- deterministic helpers ---
+
+(commerce-test
+  "amount-for-ten"
+  (promo-amount-for gctx cart ruleset "TEN")
+  300)
+(commerce-test
+  "amount-for-mem-guest"
+  (promo-amount-for gctx cart ruleset "MEM")
+  0)
+(commerce-test
+  "amount-for-mem-member"
+  (promo-amount-for mctx cart ruleset "MEM")
+  450)
+(commerce-test
+  "amount-for-absent"
+  (promo-amount-for gctx cart ruleset "NOPE")
+  0)

lib/commerce/tests/quote.sx

@@ -0,0 +1,108 @@
+;; lib/commerce/tests/quote.sx — composed priced quote (price+promo+stacking).
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define
+  tax-rules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :reduced :guest 500)
+    (list :uk :zero-rated :guest 0)
+    (list :uk :standard :member 2000)
+    (list :uk :reduced :member 500)
+    (list :uk :zero-rated :member 0)))
+
+(define gctx (make-pricing-context pcat tax-rules :uk :guest))
+(define mctx (make-pricing-context pcat tax-rules :uk :member))
+
+(define
+  cart
+  (list
+    (list "widget" :none 3)
+    (list "book" :none 1)
+    (list "tea" :none 6)))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :percent "TWENTY" :standard 2000)
+    (list :fixed "FIVER" 5000 500)
+    (list :bundle "B3T" "tea" 3)
+    (list :member "MEM" :standard 2500)))
+
+(define
+  exclusions
+  (list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
+
+;; subtotal: 3000 + 800 + 6000 = 9800
+;; tax (gross): widget 600 + tea 300 + book 0 = 900
+;; guest discount: TWENTY 600 + FIVER 500 + B3T 2000 = 3100
+;; guest total: 9800 - 3100 + 900 = 7600
+
+(define gq (cart-quote gctx cart ruleset exclusions))
+
+(commerce-test "quote-subtotal" (quote-subtotal gq) 9800)
+(commerce-test "quote-tax" (quote-tax gq) 900)
+(commerce-test "quote-discount-guest" (quote-discount gq) 3100)
+(commerce-test "quote-total-guest" (quote-total gq) 7600)
+(commerce-test
+  "quote-codes-guest"
+  (quote-codes gq)
+  (list "TWENTY" "FIVER" "B3T"))
+
+(commerce-test "quote-full-guest" gq {:codes (list "TWENTY" "FIVER" "B3T") :subtotal 9800 :discount 3100 :total 7600 :tax 900})
+
+;; member discount: MEM 750 + FIVER 500 + B3T 2000 = 3250
+;; member total: 9800 - 3250 + 900 = 7450
+(define mq (cart-quote mctx cart ruleset exclusions))
+
+(commerce-test "quote-discount-member" (quote-discount mq) 3250)
+(commerce-test "quote-total-member" (quote-total mq) 7450)
+(commerce-test
+  "quote-codes-member"
+  (quote-codes mq)
+  (list "FIVER" "B3T" "MEM"))
+
+;; --- determinism: same inputs, identical quote ---
+
+(commerce-test
+  "quote-deterministic"
+  (=
+    (cart-quote gctx cart ruleset exclusions)
+    (cart-quote gctx cart ruleset exclusions))
+  true)
+
+;; --- no promos: discount 0, total = subtotal + tax ---
+
+(commerce-test
+  "quote-no-promos"
+  (cart-quote gctx cart (list) (list))
+  {:codes (list) :subtotal 9800 :discount 0 :total 10700 :tax 900})
+
+;; --- empty cart ---
+
+(commerce-test
+  "quote-empty"
+  (cart-quote gctx empty-cart ruleset exclusions)
+  {:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})
+
+;; --- session convenience ---
+
+(define
+  sess
+  (commerce-add (commerce-session gctx) "widget" :none 3))
+
+(commerce-test
+  "session-quote"
+  (quote-total (session-quote sess ruleset exclusions))
+  3000)

lib/commerce/tests/recon.sx

@@ -0,0 +1,109 @@
+;; lib/commerce/tests/recon.sx — reconciliation as relational ledger queries.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+
+(define b (persist/mem-backend))
+
+;; OK1 — clean payment
+(define _ok (order-create b "OK1" 1 q1))
+(define _okp (order-pay b "OK1" "ok-ref" 2 1200))
+
+;; OVER1 — double charge under two different refs
+(define _ov (order-create b "OVER1" 1 q1))
+(define _ova (order-pay b "OVER1" "ov-a" 2 1200))
+(define _ovb (order-pay b "OVER1" "ov-b" 3 1200))
+
+;; UNDER1 — short payment
+(define _un (order-create b "UNDER1" 1 q1))
+(define _unp (order-pay b "UNDER1" "un-ref" 2 900))
+
+;; PART1 — paid in full, then partially refunded
+(define _pa (order-create b "PART1" 1 q1))
+(define _pap (order-pay b "PART1" "pa-ref" 2 1200))
+(define _par (order-refund b "PART1" "pa-rf" 3 200))
+
+;; REPLAY1 — webhook fires twice with the same ref (idempotent)
+(define _rp (order-create b "REPLAY1" 1 q1))
+(define _rpa (order-pay b "REPLAY1" "rp-ref" 2 1200))
+(define _rpb (order-pay b "REPLAY1" "rp-ref" 2 1200))
+
+;; PEND1 — created, not yet paid
+(define _pe (order-create b "PEND1" 1 q1))
+
+;; --- summaries ---
+
+(commerce-test "summary-count" (len (ledger-summaries b)) 6)
+(commerce-test
+  "summary-ok1"
+  (order-summary b "order/OK1")
+  (list "order/OK1" 1200 1200 0 1200 :ok))
+(commerce-test
+  "summary-part1"
+  (order-summary b "order/PART1")
+  (list "order/PART1" 1200 1200 200 1000 :underpaid))
+
+;; --- forward status query ---
+
+(commerce-test
+  "status-forward-ok"
+  (run* st (recon-statuso (ledger-summaries b) "order/OK1" st))
+  (list :ok))
+
+;; --- backward status queries (the showcase) ---
+
+(commerce-test
+  "settled"
+  (sort (settled-orders b))
+  (sort (list "order/OK1" "order/REPLAY1")))
+(commerce-test "overpaid" (overpaid-orders b) (list "order/OVER1"))
+(commerce-test
+  "underpaid"
+  (sort (underpaid-orders b))
+  (sort (list "order/UNDER1" "order/PART1")))
+(commerce-test "unpaid" (unpaid-orders b) (list "order/PEND1"))
+(commerce-test
+  "mismatched"
+  (sort (mismatched-orders b))
+  (sort (list "order/OVER1" "order/UNDER1" "order/PART1")))
+
+;; --- backward net-amount query ---
+
+(commerce-test
+  "net-1200"
+  (sort (orders-with-net b 1200))
+  (sort (list "order/OK1" "order/REPLAY1")))
+(commerce-test
+  "net-2400"
+  (orders-with-net b 2400)
+  (list "order/OVER1"))
+(commerce-test
+  "net-900"
+  (orders-with-net b 900)
+  (list "order/UNDER1"))
+
+;; --- discrepancy: +1200 (over) - 300 (under) - 200 (refund) = 700 ---
+
+(commerce-test "discrepancy" (ledger-discrepancy b) 700)
+
+;; --- double-charge guard ---
+
+(commerce-test "double-charge-detected" (order-recon b "OVER1") :overpaid)
+(commerce-test "double-charge-amount" (order-paid b "OVER1") 2400)
+
+;; --- partial refund ---
+
+(commerce-test "partial-refund-net" (order-recon b "PART1") :underpaid)
+(commerce-test
+  "partial-refund-amount"
+  (order-refunded-amount-of (order-events b "PART1"))
+  200)
+
+;; --- webhook replay: same ref twice records once ---
+
+(commerce-test
+  "replay-single-event"
+  (len (order-events b "REPLAY1"))
+  2)
+(commerce-test "replay-paid-once" (order-paid b "REPLAY1") 1200)
+(commerce-test "replay-settled" (order-recon b "REPLAY1") :ok)

lib/commerce/tests/refund.sx

@@ -0,0 +1,78 @@
+;; lib/commerce/tests/refund.sx — refund lifecycle as a flow-on-sx flow.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;; Builds the (expensive) flow env once; all assertions share it.
+
+(define env (refund-make-env))
+(define b (persist/mem-backend))
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+
+;; a paid, fulfilled order to refund (set up directly via the ledger)
+(define _c (order-create b "O1" 1 q1))
+(define _p (order-pay b "O1" "pay-1" 2 1200))
+(commerce-test "setup-recon-ok" (order-recon b "O1") :ok)
+
+;; --- happy path: request -> approve -> settle ---
+
+(define rid (refund-begin! env b "O1" "rf-1" 10 500))
+
+(commerce-test "begin-waiting-approve" (order-flow-waiting env rid) "approve")
+(commerce-test
+  "begin-not-yet-refunded"
+  (order-refunded-amount-of (order-events b "O1"))
+  0)
+(commerce-test "begin-recon-unchanged" (order-recon b "O1") :ok)
+
+(define a1 (refund-approve! env rid))
+(commerce-test "approve-result" a1 :approved)
+(commerce-test "approve-waiting-settle" (order-flow-waiting env rid) "settle")
+
+(define s1 (refund-settle! env b rid "O1" "rf-1" 11 500))
+(commerce-test "settle-result" s1 :settled)
+(commerce-test "settle-flow-done" (order-flow-status env rid) "done")
+(commerce-test
+  "settle-refunded-amount"
+  (order-refunded-amount-of (order-events b "O1"))
+  500)
+;; net 1200 - 500 = 700 < total 1200 -> underpaid (partial refund)
+(commerce-test "settle-recon-underpaid" (order-recon b "O1") :underpaid)
+
+;; --- idempotent settle: replayed provider callback is a no-op ---
+
+(define s1b (refund-settle! env b rid "O1" "rf-1" 11 500))
+(commerce-test "replay-already-settled" s1b :already-settled)
+(commerce-test
+  "replay-refunded-once"
+  (order-refunded-amount-of (order-events b "O1"))
+  500)
+
+;; --- reject path: approval denied, books untouched ---
+
+(define _c2 (order-create b "O2" 1 q1))
+(define _p2 (order-pay b "O2" "pay-2" 2 1200))
+
+(define rid2 (refund-begin! env b "O2" "rf-2" 20 1200))
+(commerce-test
+  "reject-waiting-approve"
+  (order-flow-waiting env rid2)
+  "approve")
+
+(define j2 (refund-reject! env b "O2" rid2 21 "policy"))
+(commerce-test "reject-result" j2 :rejected)
+(commerce-test "reject-flow-not-waiting" (order-flow-waiting env rid2) nil)
+(commerce-test
+  "reject-no-refund"
+  (order-refunded-amount-of (order-events b "O2"))
+  0)
+(commerce-test "reject-recon-ok" (order-recon b "O2") :ok)
+
+;; settling a rejected/cancelled refund does nothing
+(define s2 (refund-settle! env b rid2 "O2" "rf-2" 22 1200))
+(commerce-test "reject-then-settle-noop" s2 :already-settled)
+(commerce-test
+  "reject-still-no-refund"
+  (order-refunded-amount-of (order-events b "O2"))
+  0)
+
+;; --- distinct flow ids ---
+
+(commerce-test "distinct-refund-ids" (not (= rid rid2)) true)

lib/commerce/tests/stack.sx

@@ -0,0 +1,127 @@
+;; lib/commerce/tests/stack.sx — stacking precedence, exclusivity, best price.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define gctx (make-pricing-context pcat (list) :uk :guest))
+(define mctx (make-pricing-context pcat (list) :uk :member))
+
+(define
+  cart
+  (list
+    (list "widget" :none 3)
+    (list "book" :none 1)
+    (list "tea" :none 6)))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :percent "TWENTY" :standard 2000)
+    (list :fixed "FIVER" 5000 500)
+    (list :bundle "B3T" "tea" 3)
+    (list :member "MEM" :standard 2500)))
+
+;; The three standard-class discounts are mutually exclusive.
+(define
+  exclusions
+  (list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
+
+;; --- exclusivity predicates ---
+
+(commerce-test
+  "excluded-pair-direct"
+  (excluded-pair? exclusions "TEN" "TWENTY")
+  true)
+(commerce-test
+  "excluded-pair-symmetric"
+  (excluded-pair? exclusions "TWENTY" "TEN")
+  true)
+(commerce-test
+  "excluded-pair-none"
+  (excluded-pair? exclusions "TEN" "FIVER")
+  false)
+(commerce-test
+  "compatible-yes"
+  (compatible? exclusions (list "FIVER" "B3T" "TWENTY"))
+  true)
+(commerce-test
+  "compatible-no"
+  (compatible? exclusions (list "TEN" "TWENTY" "B3T"))
+  false)
+
+;; --- powerset + valid stackings ---
+
+(commerce-test
+  "powerset-size"
+  (len (powerset (list 1 2 3 4)))
+  16)
+
+(define gappl (applicable-promos gctx cart ruleset))
+
+(commerce-test "applicable-guest-count" (len gappl) 4)
+
+;; 16 subsets minus the 4 containing both TEN and TWENTY = 12 legal.
+(commerce-test
+  "valid-stackings-count"
+  (len (valid-stackings exclusions gappl))
+  12)
+
+(commerce-test
+  "stacking-total"
+  (stacking-total (list (list "TWENTY" 600) (list "B3T" 2000)))
+  2600)
+
+;; --- best price (deterministic selection) ---
+
+(commerce-test
+  "best-discount-guest"
+  (best-promo-discount gctx cart ruleset exclusions)
+  3100)
+(commerce-test
+  "best-codes-guest"
+  (best-promo-codes gctx cart ruleset exclusions)
+  (list "TWENTY" "FIVER" "B3T"))
+
+;; exclusivity holds: the cheaper conflicting code is dropped.
+(commerce-test
+  "best-excludes-ten"
+  (some
+    (fn (c) (= c "TEN"))
+    (best-promo-codes gctx cart ruleset exclusions))
+  false)
+
+;; --- member vs guest ---
+
+(commerce-test
+  "best-discount-member"
+  (best-promo-discount mctx cart ruleset exclusions)
+  3250)
+(commerce-test
+  "best-codes-member"
+  (best-promo-codes mctx cart ruleset exclusions)
+  (list "FIVER" "B3T" "MEM"))
+
+;; --- best price backward query (the showcase) ---
+
+(commerce-test
+  "stacking-by-total-backward"
+  (run*
+    codes
+    (stacking-by-totalo (valid-stackings exclusions gappl) codes 3100))
+  (list (list "TWENTY" "FIVER" "B3T")))
+
+;; --- edge: no applicable promos ---
+
+(commerce-test
+  "best-empty"
+  (best-promo-discount gctx empty-cart ruleset exclusions)
+  0)

lib/commerce/tests/stock.sx

@@ -0,0 +1,122 @@
+;; lib/commerce/tests/stock.sx — stock-constrained reservation.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  cat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "gadget" 2500 :standard))
+    (list)
+    (list
+      (list "widget" :small 5)
+      (list "widget" :large 0)
+      (list "gadget" :std 12))))
+
+;; --- availability ---
+
+(commerce-test
+  "available-found"
+  (available-stock cat "widget" :small)
+  5)
+(commerce-test
+  "available-zero"
+  (available-stock cat "widget" :large)
+  0)
+(commerce-test
+  "available-absent"
+  (available-stock cat "widget" :none)
+  0)
+
+;; --- per-line reservability ---
+
+(commerce-test
+  "shortfall-fits"
+  (line-shortfall cat (list "widget" :small 5))
+  0)
+(commerce-test
+  "shortfall-over"
+  (line-shortfall cat (list "widget" :small 8))
+  3)
+(commerce-test
+  "reservable-yes"
+  (line-reservable? cat (list "gadget" :std 12))
+  true)
+(commerce-test
+  "reservable-no"
+  (line-reservable? cat (list "widget" :large 1))
+  false)
+
+;; --- cart-level reservation check ---
+
+(commerce-test
+  "can-reserve-yes"
+  (can-reserve?
+    cat
+    (list (list "widget" :small 5) (list "gadget" :std 2)))
+  true)
+
+(commerce-test
+  "can-reserve-no"
+  (can-reserve? cat (list (list "widget" :small 9)))
+  false)
+
+(commerce-test
+  "shortfalls-detail"
+  (reservation-shortfalls
+    cat
+    (list (list "widget" :small 9) (list "gadget" :std 2)))
+  (list {:requested 9 :available 5 :sku "widget" :variant :small :short 4}))
+
+(commerce-test
+  "reserve-check-ok"
+  (reserve-check cat (list (list "gadget" :std 1)))
+  :ok)
+
+(commerce-test
+  "reserve-check-rejected"
+  (reserve-check cat (list (list "widget" :large 1)))
+  {:shortfalls (list {:requested 1 :available 0 :sku "widget" :variant :large :short 1}) :rejected :insufficient-stock})
+
+;; --- reservation view: concurrent holds reduce availability ---
+
+(define held (list (list "widget" :small 3)))
+
+(commerce-test
+  "effective-after-hold"
+  (effective-available cat held "widget" :small)
+  2)
+(commerce-test
+  "effective-other-unaffected"
+  (effective-available cat held "gadget" :std)
+  12)
+(commerce-test
+  "reservable-with-fits"
+  (line-reservable-with? cat held (list "widget" :small 2))
+  true)
+(commerce-test
+  "reservable-with-over"
+  (line-reservable-with? cat held (list "widget" :small 3))
+  false)
+
+;; --- relational availability query (multidirectional) ---
+
+(commerce-test
+  "sufficient-forward"
+  (run*
+    x
+    (fresh () (sufficient-stocko cat "widget" :small 5) (== x true)))
+  (list true))
+
+(commerce-test
+  "sufficient-forward-over"
+  (run*
+    x
+    (fresh () (sufficient-stocko cat "widget" :small 6) (== x true)))
+  (list))
+
+;; backward: which variants of widget can supply 1 unit?
+(commerce-test
+  "variants-supplying-1"
+  (run* v (fresh (q) (stocko cat "widget" v q) (lteo-i 1 q)))
+  (list :small))

lib/commerce/tests/window.sx

@@ -0,0 +1,112 @@
+;; lib/commerce/tests/window.sx — time-windowed promotions.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog (list (list "widget" 1000 :standard)) (list) (list)))
+
+(define gctx (make-pricing-context pcat (list) :uk :guest))
+(define cart (list (list "widget" :none 3)))
+
+(define ten (list :percent "TEN" :standard 1000))
+(define twenty (list :percent "TWENTY" :standard 2000))
+(define always (list :fixed "ALWAYS" 0 100))
+
+(define
+  windowed
+  (list
+    (windowed-promo ten 100 200)
+    (windowed-promo twenty 150 300)
+    (windowed-promo always nil nil)))
+
+(define exclusions (list (list "TEN" "TWENTY")))
+
+;; --- wp-active? boundaries (inclusive) ---
+
+(commerce-test
+  "active-at-from"
+  (wp-active? (windowed-promo ten 100 200) 100)
+  true)
+(commerce-test
+  "active-at-until"
+  (wp-active? (windowed-promo ten 100 200) 200)
+  true)
+(commerce-test
+  "inactive-before"
+  (wp-active? (windowed-promo ten 100 200) 99)
+  false)
+(commerce-test
+  "inactive-after"
+  (wp-active? (windowed-promo ten 100 200) 201)
+  false)
+(commerce-test
+  "open-ended-always"
+  (wp-active? (windowed-promo always nil nil) 99999)
+  true)
+(commerce-test
+  "open-lower"
+  (wp-active? (windowed-promo ten nil 200) 1)
+  true)
+(commerce-test
+  "open-upper"
+  (wp-active? (windowed-promo ten 100 nil) 99999)
+  true)
+
+;; --- active-ruleset filtering ---
+
+(commerce-test
+  "active-ruleset-120"
+  (active-ruleset windowed 120)
+  (list ten always))
+(commerce-test
+  "active-ruleset-160"
+  (active-ruleset windowed 160)
+  (list ten twenty always))
+(commerce-test
+  "active-ruleset-250"
+  (active-ruleset windowed 250)
+  (list twenty always))
+(commerce-test
+  "active-ruleset-50"
+  (active-ruleset windowed 50)
+  (list always))
+
+;; --- active-codes (backward query) ---
+
+(commerce-test
+  "active-codes-120"
+  (active-codes windowed 120)
+  (list "TEN" "ALWAYS"))
+(commerce-test
+  "active-codes-160"
+  (active-codes windowed 160)
+  (list "TEN" "TWENTY" "ALWAYS"))
+(commerce-test
+  "active-codes-50"
+  (active-codes windowed 50)
+  (list "ALWAYS"))
+
+;; --- windowed-quote: discount changes with time (deterministic) ---
+;; subtotal 3000, no tax. TEN=300, TWENTY=600, ALWAYS=100; TEN/TWENTY exclusive.
+
+(commerce-test
+  "quote-50"
+  (quote-discount (windowed-quote gctx cart windowed exclusions 50))
+  100)
+(commerce-test
+  "quote-120"
+  (quote-discount (windowed-quote gctx cart windowed exclusions 120))
+  400)
+(commerce-test
+  "quote-160"
+  (quote-discount (windowed-quote gctx cart windowed exclusions 160))
+  700)
+(commerce-test
+  "quote-250"
+  (quote-discount (windowed-quote gctx cart windowed exclusions 250))
+  700)
+
+(commerce-test
+  "quote-total-160"
+  (quote-total (windowed-quote gctx cart windowed exclusions 160))
+  2300)

lib/commerce/window.sx

@@ -0,0 +1,55 @@
+;; lib/commerce/window.sx — time-windowed promotions.
+;;
+;; A promo's validity window is kept SEPARATE from the promo tuple (so promo.sx
+;; is untouched): a windowed promo is (list promo from until) with inclusive
+;; integer timestamps (same time model as the ledger `at`). nil from = no lower
+;; bound; nil until = open-ended.
+;;
+;; `active-ruleset` filters a windowed ruleset to the plain promos live at a
+;; given time, which feeds straight into promo/stack/quote — so a datetime-aware
+;; quote is just the existing pipeline over the active set. Deterministic: the
+;; quote is a pure function of (ctx, cart, windowed-ruleset, exclusions, at).
+
+(define windowed-promo (fn (promo from until) (list promo from until)))
+
+(define wp-promo (fn (wp) (nth wp 0)))
+(define wp-from (fn (wp) (nth wp 1)))
+(define wp-until (fn (wp) (nth wp 2)))
+
+(define
+  wp-active?
+  (fn
+    (wp at)
+    (let
+      ((from (wp-from wp)) (until (wp-until wp)))
+      (and (or (nil? from) (>= at from)) (or (nil? until) (<= at until))))))
+
+;; Plain promo tuples live at time `at` — feed into cart-quote / best-promo-*.
+(define
+  active-ruleset
+  (fn
+    (windowed at)
+    (map wp-promo (filter (fn (wp) (wp-active? wp at)) windowed))))
+
+;; Relation: which promo codes are active at `at`? (backward query)
+(define
+  active-promoo
+  (fn
+    (windowed at code)
+    (fresh
+      (wp)
+      (membero wp windowed)
+      (project
+        (wp)
+        (if (wp-active? wp at) (== code (promo-code (wp-promo wp))) fail)))))
+
+(define
+  active-codes
+  (fn (windowed at) (run* code (active-promoo windowed at code))))
+
+;; Datetime-aware quote: the existing pipeline over the time-active ruleset.
+(define
+  windowed-quote
+  (fn
+    (ctx cart windowed exclusions at)
+    (cart-quote ctx cart (active-ruleset windowed at) exclusions)))

lib/common-lisp/conformance.conf

@@ -1,67 +0,0 @@
-# Common-Lisp-on-SX conformance config — sourced by lib/guest/conformance.sh.
-#
-# CL suites run their tests at *load* time, mutating per-suite global counters
-# (different variable names per suite), and each suite needs a different
-# preload chain. Both are expressed via the extended MODE=counters SUITES
-# format: "name:file:pass-var:fail-var:extra-preload ...".
-
-LANG_NAME=common-lisp
-MODE=counters
-# No global counter defaults — every suite names its own pair below.
-COUNTERS_PASS=
-COUNTERS_FAIL=
-TIMEOUT_PER_SUITE=180
-
-# Base preloads common to every suite (loaded before each suite's own chain).
-PRELOADS=(
-  spec/stdlib.sx
-  lib/guest/prefix.sx
-)
-
-# name:file:pass-var:fail-var:extra-preloads(space-separated)
-SUITES=(
-  "read:lib/common-lisp/tests/read.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx"
-  "lambda:lib/common-lisp/tests/lambda.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx lib/common-lisp/parser.sx"
-  "eval:lib/common-lisp/tests/eval.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx"
-  "conditions:lib/common-lisp/tests/conditions.sx:passed:failed:lib/common-lisp/runtime.sx"
-  "restart-demo:lib/common-lisp/tests/programs/restart-demo.sx:demo-passed:demo-failed:lib/common-lisp/runtime.sx"
-  "parse-recover:lib/common-lisp/tests/programs/parse-recover.sx:parse-passed:parse-failed:lib/common-lisp/runtime.sx"
-  "interactive-debugger:lib/common-lisp/tests/programs/interactive-debugger.sx:debugger-passed:debugger-failed:lib/common-lisp/runtime.sx"
-  "clos:lib/common-lisp/tests/clos.sx:passed:failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
-  "geometry:lib/common-lisp/tests/programs/geometry.sx:geo-passed:geo-failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
-  "mop-trace:lib/common-lisp/tests/programs/mop-trace.sx:mop-passed:mop-failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
-  "macros:lib/common-lisp/tests/macros.sx:macro-passed:macro-failed:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx"
-  "stdlib:lib/common-lisp/tests/stdlib.sx:stdlib-passed:stdlib-failed:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx"
-)
-
-# Preserve the historical scoreboard schema (total_pass/total_fail, suites with
-# name/pass/fail) so any consumer of lib/common-lisp/scoreboard.json keeps working.
-emit_scoreboard_json() {
-  local n=${#GC_NAMES[@]} i
-  printf '{\n'
-  printf '  "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
-  printf '  "total_pass": %d,\n' "$GC_TOTAL_PASS"
-  printf '  "total_fail": %d,\n' "$GC_TOTAL_FAIL"
-  printf '  "suites": [\n'
-  for ((i=0; i<n; i++)); do
-    [ "$i" -gt 0 ] && printf ',\n'
-    printf '    {"name": "%s", "pass": %d, "fail": %d}' \
-      "${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}"
-  done
-  printf '\n  ]\n'
-  printf '}\n'
-}
-
-emit_scoreboard_md() {
-  local n=${#GC_NAMES[@]} i p f status
-  printf '# Common Lisp on SX — Scoreboard\n\n'
-  printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
-  printf '| Suite | Pass | Fail | Status |\n'
-  printf '|-------|------|------|--------|\n'
-  for ((i=0; i<n; i++)); do
-    p="${GC_PASS[$i]}"; f="${GC_FAIL[$i]}"
-    if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then status="pass"; else status="FAIL"; fi
-    printf '| %s | %s | %s | %s |\n' "${GC_NAMES[$i]}" "$p" "$f" "$status"
-  done
-  printf '\n**Total: %d passed, %d failed**\n' "$GC_TOTAL_PASS" "$GC_TOTAL_FAIL"
-}

lib/common-lisp/conformance.sh

@@ -1,3 +1,161 @@
 #!/usr/bin/env bash
-# Thin wrapper — see lib/guest/conformance.sh and lib/common-lisp/conformance.conf.
-exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
+# lib/common-lisp/conformance.sh — CL-on-SX conformance test runner
+#
+# Runs all Common Lisp test suites and writes scoreboard.json + scoreboard.md.
+#
+# Usage:
+#   bash lib/common-lisp/conformance.sh
+#   bash lib/common-lisp/conformance.sh -v
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
+fi
+if [ ! -x "$SX_SERVER" ]; then
+  echo "ERROR: sx_server.exe not found."
+  exit 1
+fi
+
+VERBOSE="${1:-}"
+TOTAL_PASS=0; TOTAL_FAIL=0
+SUITE_NAMES=()
+SUITE_PASS=()
+SUITE_FAIL=()
+
+# run_suite NAME "file1 file2 ..." PASS_VAR FAIL_VAR FAILURES_VAR
+run_suite() {
+  local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5"
+  local TMP; TMP=$(mktemp)
+  {
+    printf '(epoch 1)\n(load "spec/stdlib.sx")\n(load "lib/guest/prefix.sx")\n'
+    local i=2
+    for f in $load_files; do
+      printf '(epoch %d)\n(load "%s")\n' "$i" "$f"
+      i=$((i+1))
+    done
+    printf '(epoch 100)\n(eval "%s")\n' "$pass_var"
+    printf '(epoch 101)\n(eval "%s")\n' "$fail_var"
+  } > "$TMP"
+  local OUT; OUT=$(timeout 30 "$SX_SERVER" < "$TMP" 2>/dev/null)
+  rm -f "$TMP"
+  local P F
+  P=$(echo "$OUT" | grep -A1 "^(ok-len 100 " | tail -1 | tr -d ' ()' || true)
+  F=$(echo "$OUT" | grep -A1 "^(ok-len 101 " | tail -1 | tr -d ' ()' || true)
+  # Also try plain (ok 100 N) format
+  [ -z "$P" ] && P=$(echo "$OUT" | grep "^(ok 100 " | awk '{print $3}' | tr -d ')' || true)
+  [ -z "$F" ] && F=$(echo "$OUT" | grep "^(ok 101 " | awk '{print $3}' | tr -d ')' || true)
+  [ -z "$P" ] && P=0; [ -z "$F" ] && F=0
+  SUITE_NAMES+=("$name")
+  SUITE_PASS+=("$P")
+  SUITE_FAIL+=("$F")
+  TOTAL_PASS=$((TOTAL_PASS + P))
+  TOTAL_FAIL=$((TOTAL_FAIL + F))
+  if [ "$F" = "0" ] && [ "${P:-0}" -gt 0 ] 2>/dev/null; then
+    echo "  PASS  $name ($P tests)"
+  else
+    echo "  FAIL  $name ($P passed, $F failed)"
+  fi
+}
+
+echo "=== Common Lisp on SX — Conformance Run ==="
+echo ""
+
+run_suite "Phase 1: tokenizer/reader" \
+  "lib/common-lisp/reader.sx lib/common-lisp/tests/read.sx" \
+  "cl-test-pass" "cl-test-fail" "cl-test-fails"
+
+run_suite "Phase 1: parser/lambda-lists" \
+  "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/tests/lambda.sx" \
+  "cl-test-pass" "cl-test-fail" "cl-test-fails"
+
+run_suite "Phase 2: evaluator" \
+  "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/eval.sx" \
+  "cl-test-pass" "cl-test-fail" "cl-test-fails"
+
+run_suite "Phase 3: condition system" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/tests/conditions.sx" \
+  "passed" "failed" "failures"
+
+run_suite "Phase 3: restart-demo" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/restart-demo.sx" \
+  "demo-passed" "demo-failed" "demo-failures"
+
+run_suite "Phase 3: parse-recover" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/parse-recover.sx" \
+  "parse-passed" "parse-failed" "parse-failures"
+
+run_suite "Phase 3: interactive-debugger" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/interactive-debugger.sx" \
+  "debugger-passed" "debugger-failed" "debugger-failures"
+
+run_suite "Phase 4: CLOS" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/clos.sx" \
+  "passed" "failed" "failures"
+
+run_suite "Phase 4: geometry" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/geometry.sx" \
+  "geo-passed" "geo-failed" "geo-failures"
+
+run_suite "Phase 4: mop-trace" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/mop-trace.sx" \
+  "mop-passed" "mop-failed" "mop-failures"
+
+run_suite "Phase 5: macros+LOOP" \
+  "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx lib/common-lisp/tests/macros.sx" \
+  "macro-passed" "macro-failed" "macro-failures"
+
+run_suite "Phase 6: stdlib" \
+  "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/stdlib.sx" \
+  "stdlib-passed" "stdlib-failed" "stdlib-failures"
+
+echo ""
+echo "=== Total: $TOTAL_PASS passed, $TOTAL_FAIL failed ==="
+
+# ── write scoreboard.json ─────────────────────────────────────────────────
+
+SCORE_DIR="lib/common-lisp"
+JSON="$SCORE_DIR/scoreboard.json"
+{
+  printf '{\n'
+  printf '  "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
+  printf '  "total_pass": %d,\n' "$TOTAL_PASS"
+  printf '  "total_fail": %d,\n' "$TOTAL_FAIL"
+  printf '  "suites": [\n'
+  first=true
+  for i in "${!SUITE_NAMES[@]}"; do
+    if [ "$first" = "true" ]; then first=false; else printf ',\n'; fi
+    printf '    {"name": "%s", "pass": %d, "fail": %d}' \
+      "${SUITE_NAMES[$i]}" "${SUITE_PASS[$i]}" "${SUITE_FAIL[$i]}"
+  done
+  printf '\n  ]\n'
+  printf '}\n'
+} > "$JSON"
+
+# ── write scoreboard.md ───────────────────────────────────────────────────
+
+MD="$SCORE_DIR/scoreboard.md"
+{
+  printf '# Common Lisp on SX — Scoreboard\n\n'
+  printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
+  printf '| Suite | Pass | Fail | Status |\n'
+  printf '|-------|------|------|--------|\n'
+  for i in "${!SUITE_NAMES[@]}"; do
+    p="${SUITE_PASS[$i]}" f="${SUITE_FAIL[$i]}"
+    status=""
+    if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then
+      status="pass"
+    else
+      status="FAIL"
+    fi
+    printf '| %s | %s | %s | %s |\n' "${SUITE_NAMES[$i]}" "$p" "$f" "$status"
+  done
+  printf '\n**Total: %d passed, %d failed**\n' "$TOTAL_PASS" "$TOTAL_FAIL"
+} > "$MD"
+
+echo ""
+echo "Scoreboard written to $JSON and $MD"
+
+[ "$TOTAL_FAIL" -eq 0 ]

lib/common-lisp/scoreboard.json

@@ -1,19 +1,19 @@
 {
-  "generated": "2026-06-07T09:35:38Z",
-  "total_pass": 487,
+  "generated": "2026-05-06T22:55:42Z",
+  "total_pass": 518,
   "total_fail": 0,
   "suites": [
-    {"name": "read", "pass": 79, "fail": 0},
-    {"name": "lambda", "pass": 31, "fail": 0},
-    {"name": "eval", "pass": 182, "fail": 0},
-    {"name": "conditions", "pass": 59, "fail": 0},
-    {"name": "restart-demo", "pass": 7, "fail": 0},
-    {"name": "parse-recover", "pass": 6, "fail": 0},
-    {"name": "interactive-debugger", "pass": 7, "fail": 0},
-    {"name": "clos", "pass": 35, "fail": 0},
-    {"name": "geometry", "pass": 0, "fail": 0},
-    {"name": "mop-trace", "pass": 0, "fail": 0},
-    {"name": "macros", "pass": 27, "fail": 0},
-    {"name": "stdlib", "pass": 54, "fail": 0}
+    {"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0},
+    {"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0},
+    {"name": "Phase 2: evaluator", "pass": 182, "fail": 0},
+    {"name": "Phase 3: condition system", "pass": 59, "fail": 0},
+    {"name": "Phase 3: restart-demo", "pass": 7, "fail": 0},
+    {"name": "Phase 3: parse-recover", "pass": 6, "fail": 0},
+    {"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0},
+    {"name": "Phase 4: CLOS", "pass": 41, "fail": 0},
+    {"name": "Phase 4: geometry", "pass": 12, "fail": 0},
+    {"name": "Phase 4: mop-trace", "pass": 13, "fail": 0},
+    {"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0},
+    {"name": "Phase 6: stdlib", "pass": 54, "fail": 0}
   ]
 }

lib/common-lisp/scoreboard.md

@@ -1,20 +1,20 @@
 # Common Lisp on SX — Scoreboard
 
-_Generated: 2026-06-07 09:35 UTC_
+_Generated: 2026-05-06 22:55 UTC_
 
 | Suite | Pass | Fail | Status |
 |-------|------|------|--------|
-| read | 79 | 0 | pass |
-| lambda | 31 | 0 | pass |
-| eval | 182 | 0 | pass |
-| conditions | 59 | 0 | pass |
-| restart-demo | 7 | 0 | pass |
-| parse-recover | 6 | 0 | pass |
-| interactive-debugger | 7 | 0 | pass |
-| clos | 35 | 0 | pass |
-| geometry | 0 | 0 | FAIL |
-| mop-trace | 0 | 0 | FAIL |
-| macros | 27 | 0 | pass |
-| stdlib | 54 | 0 | pass |
+| Phase 1: tokenizer/reader | 79 | 0 | pass |
+| Phase 1: parser/lambda-lists | 31 | 0 | pass |
+| Phase 2: evaluator | 182 | 0 | pass |
+| Phase 3: condition system | 59 | 0 | pass |
+| Phase 3: restart-demo | 7 | 0 | pass |
+| Phase 3: parse-recover | 6 | 0 | pass |
+| Phase 3: interactive-debugger | 7 | 0 | pass |
+| Phase 4: CLOS | 41 | 0 | pass |
+| Phase 4: geometry | 12 | 0 | pass |
+| Phase 4: mop-trace | 13 | 0 | pass |
+| Phase 5: macros+LOOP | 27 | 0 | pass |
+| Phase 6: stdlib | 54 | 0 | pass |
 
-**Total: 487 passed, 0 failed**
+**Total: 518 passed, 0 failed**

lib/content/anchor.sx

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

lib/content/api.sx

@@ -1,67 +0,0 @@
-;; 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)

lib/content/block.sx

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

lib/content/callout.sx

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

lib/content/clone.sx

@@ -1,34 +0,0 @@
-;; 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)))))

lib/content/compose.sx

@@ -1,42 +0,0 @@
-;; 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))))))

lib/content/conformance.sh

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

lib/content/crdt-store.sx

@@ -1,71 +0,0 @@
-;; 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))))

lib/content/crdt-tree.sx

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

lib/content/crdt.sx

@@ -1,378 +0,0 @@
-;; 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))))))

lib/content/data.sx

@@ -1,79 +0,0 @@
-;; 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))))

lib/content/doc.sx

@@ -1,203 +0,0 @@
-;; 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))))

lib/content/fed.sx

@@ -1,68 +0,0 @@
-;; 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)))

lib/content/find-replace.sx

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

lib/content/flatten.sx

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

lib/content/index.sx

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

lib/content/markdown.sx

@@ -1,55 +0,0 @@
-;; 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)

lib/content/md-doc.sx

@@ -1,63 +0,0 @@
-;; 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))))))

lib/content/md-import.sx

@@ -1,449 +0,0 @@
-;; 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})

lib/content/media.sx

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

lib/content/meta.sx

@@ -1,53 +0,0 @@
-;; 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)

lib/content/move.sx

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

lib/content/normalize.sx

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

lib/content/outline.sx

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

lib/content/page-full.sx

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

lib/content/page.sx

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

lib/content/query.sx

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

lib/content/render.sx

@@ -1,99 +0,0 @@
-;; 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)

lib/content/scoreboard.json

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

lib/content/scoreboard.md

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

lib/content/section.sx

@@ -1,103 +0,0 @@
-;; 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))))

lib/content/snapshot.sx

@@ -1,90 +0,0 @@
-;; 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))))))

lib/content/stats.sx

@@ -1,49 +0,0 @@
-;; 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)}))

lib/content/store.sx

@@ -1,101 +0,0 @@
-;; 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))))

lib/content/summary.sx

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

lib/content/sync.sx

@@ -1,74 +0,0 @@
-;; 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})

lib/content/table.sx

@@ -1,54 +0,0 @@
-;; 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))))

lib/content/tests/anchor.sx

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

lib/content/tests/api.sx

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

lib/content/tests/block.sx

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

lib/content/tests/callout.sx

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

lib/content/tests/clone.sx

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

lib/content/tests/compose.sx

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

lib/content/tests/crdt-blocks.sx

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

lib/content/tests/crdt-store.sx

@@ -1,139 +0,0 @@
-;; 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)

lib/content/tests/crdt-tree.sx

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

lib/content/tests/crdt.sx

@@ -1,315 +0,0 @@
-;; 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)

lib/content/tests/data.sx

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

lib/content/tests/doc.sx

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

lib/content/tests/fed.sx

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

lib/content/tests/find-replace.sx

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

lib/content/tests/flatten.sx

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

lib/content/tests/index.sx

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

lib/content/tests/markdown.sx

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

lib/content/tests/md-doc.sx

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

lib/content/tests/md-import.sx

@@ -1,206 +0,0 @@
-;; 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)