From 25f3734eab05f9d491cb6960025f5c4196526759 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 6 Jun 2026 23:41:04 +0000 Subject: [PATCH] commerce: catalog facts + multidirectional relations + conformance harness (16 tests) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit catalog.sx — catalog snapshot (products/variants/stock as fact tuples), relational accessors (producto/varianto/stocko, derived priceo/classo/ unit-priceo) usable forward and backward, deterministic catalog-price/ -class/-has? helpers. Money is integer minor units. conformance.sh runs suites on the miniKanren stack and emits scoreboard.{json,md}. Co-Authored-By: Claude Opus 4.8 (1M context) --- lib/commerce/catalog.sx | 83 +++++++++++++++++++++++ lib/commerce/conformance.sh | 121 ++++++++++++++++++++++++++++++++++ lib/commerce/scoreboard.json | 8 +++ lib/commerce/scoreboard.md | 8 +++ lib/commerce/tests/catalog.sx | 93 ++++++++++++++++++++++++++ plans/commerce-on-sx.md | 14 ++-- 6 files changed, 323 insertions(+), 4 deletions(-) create mode 100644 lib/commerce/catalog.sx create mode 100755 lib/commerce/conformance.sh create mode 100644 lib/commerce/scoreboard.json create mode 100644 lib/commerce/scoreboard.md create mode 100644 lib/commerce/tests/catalog.sx diff --git a/lib/commerce/catalog.sx b/lib/commerce/catalog.sx new file mode 100644 index 00000000..b29b7438 --- /dev/null +++ b/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))))) diff --git a/lib/commerce/conformance.sh b/lib/commerce/conformance.sh new file mode 100755 index 00000000..2ab01574 --- /dev/null +++ b/lib/commerce/conformance.sh @@ -0,0 +1,121 @@ +#!/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) + +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/commerce/catalog.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 300 "$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 ] diff --git a/lib/commerce/scoreboard.json b/lib/commerce/scoreboard.json new file mode 100644 index 00000000..11ab5f1e --- /dev/null +++ b/lib/commerce/scoreboard.json @@ -0,0 +1,8 @@ +{ + "suites": { + "catalog": {"pass": 16, "fail": 0} + }, + "total_pass": 16, + "total_fail": 0, + "total": 16 +} diff --git a/lib/commerce/scoreboard.md b/lib/commerce/scoreboard.md new file mode 100644 index 00000000..3d217857 --- /dev/null +++ b/lib/commerce/scoreboard.md @@ -0,0 +1,8 @@ +# commerce Conformance Scoreboard + +_Generated by `lib/commerce/conformance.sh`_ + +| Suite | Pass | Fail | Total | +|-------|-----:|-----:|------:| +| catalog | 16 | 0 | 16 | +| **Total** | **16** | **0** | **16** | diff --git a/lib/commerce/tests/catalog.sx b/lib/commerce/tests/catalog.sx new file mode 100644 index 00000000..c8808c0b --- /dev/null +++ b/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) diff --git a/plans/commerce-on-sx.md b/plans/commerce-on-sx.md index 196a2dc7..b4c07efb 100644 --- a/plans/commerce-on-sx.md +++ b/plans/commerce-on-sx.md @@ -21,7 +21,7 @@ reconciliation — all auditable via the event log. ## Status (rolling) -`bash lib/commerce/conformance.sh` → **0/0** (not yet started) +`bash lib/commerce/conformance.sh` → **16/16** (1 suite: catalog) ## Ground rules @@ -55,7 +55,7 @@ lib/commerce/api.sx ── (commerce/add) (commerce/total) (commerce/checkout) ``` ## Phase 1 — Catalog + cart + deterministic totals -- [ ] `catalog.sx` — product/variant/stock as facts +- [x] `catalog.sx` — product/variant/stock as facts - [ ] `cart.sx` — line items, add/remove/qty - [ ] `price.sx` — base pricing relation, subtotal; tax - [ ] `api.sx` + tests + scoreboard + conformance.sh @@ -76,7 +76,13 @@ lib/commerce/api.sx ── (commerce/add) (commerce/total) (commerce/checkout) - [ ] tests: webhook replay, partial refund, double-charge guard ## Progress log -(loop fills this in) +- 2026-06-06 — `catalog.sx`: catalog snapshot (products/variants/stock as fact + tuples) + multidirectional accessor relations (`producto`/`varianto`/`stocko`, + derived `priceo`/`classo`/`unit-priceo`) + deterministic `catalog-price`/ + `-class`/`-has?` helpers. `conformance.sh` harness + scoreboard. catalog suite + 16/16. Gotcha: minikanren `run-n` macro binds `s` internally — query vars must + avoid `s`; tests compare reified results with `=` (not `equal?`, which fails on + reified lists). Money = integer minor units throughout. ## Blockers -(loop fills this in) +(none)