giles
563fac9e62
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m5s
attribution.sx — the briefing's marquee "which line item triggered this discount?" backward query. promo-lines gives each promo's pure scope (percent/member -> class lines, bundle -> sku lines, fixed -> order-level); promo-toucheso relates (code, line) for applying promos, run forward (lines-for-code) and backward (codes-for-line). Additive; promo amounts unchanged. Total 201/201 across 12 suites. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
101 lines
2.6 KiB
Plaintext
101 lines
2.6 KiB
Plaintext
;; 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))))))
|