giles
79fa28e55d
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 57s
promo.sx — four promo types as tagged tuples; per-promo discount is pure
integer arithmetic, but enumeration is relational: promo-discounto and
promo-applieso run forward ("which codes apply, for how much?") and backward
("which code yields this discount?"). project grounds the membero-bound promo.
applicable-promos / promo-amount-for deterministic helpers. Total 83/83.
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
143 lines
2.9 KiB
Plaintext
143 lines
2.9 KiB
Plaintext
;; 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)
|