Skip to content

Commit

Permalink
Bug 797596 - New-owner - improved representation of payments with mul…
Browse files Browse the repository at this point in the history 
…tiple non-APAR splits

Merge branch 'bug797596' into maint
  • Loading branch information
@christopherlam
christopherlam committed Jul 6, 2021
2 parents 06fc58c + feb0480 commit c9fc781
Show file tree
Hide file tree
Showing 2 changed files with 98 additions and 65 deletions.
138 changes: 79 additions & 59 deletions gnucash/report/reports/standard/new-owner-report.scm
View file
Expand Up @@ -131,9 +131,8 @@
link-blank?)

(define-record-type :payment-info
(make-payment-info overpayment invoices opposing-splits)
(make-payment-info invoices opposing-splits)
payment-info?
(overpayment payment-info-overpayment)
(invoices payment-info-invoices)
(opposing-splits payment-info-opposing-splits))

Expand Down Expand Up @@ -201,10 +200,8 @@
desc-header sale-header tax-header debit-header credit-header
balance-header doclink-header))))

(define (make-heading-list column-vector link-option acct-type)
(let ((heading-list '())
(formal? (gnc-prefs-get-bool GNC-PREFS-GROUP-GENERAL
GNC-PREF-ACCOUNTING-LABELS)))
(define (make-heading-list column-vector link-option)
(let ((heading-list '()))
(if (date-col column-vector)
(addto! heading-list (G_ date-header)))
(if (date-due-col column-vector)
Expand All @@ -222,15 +219,9 @@
(if (tax-col column-vector)
(addto! heading-list (G_ tax-header)))
(if (debit-col column-vector)
(addto! heading-list
(if formal?
(G_ debit-header)
(gnc-account-get-debit-string acct-type))))
(addto! heading-list (G_ debit-header)))
(if (credit-col column-vector)
(addto! heading-list
(if formal?
(G_ credit-header)
(gnc-account-get-credit-string acct-type))))
(addto! heading-list (G_ credit-header)))
(if (bal-col column-vector)
(addto! heading-list (G_ balance-header)))
(case link-option
Expand Down Expand Up @@ -485,6 +476,8 @@
(define mid-span
(if (eq? link-option 'detailed) (num-cols used-columns 'mid-spac) 0))

(define add-derived-amounts-disclaimer? #f)

(define (split->anchor split negate?)
(gnc:html-markup-anchor
(gnc:split-anchor-text split)
Expand Down Expand Up @@ -515,8 +508,13 @@
(addif (debit-col used-columns) (make-cell debit))
(addif (credit-col used-columns) (make-cell credit))
(addif (bal-col used-columns) (make-cell total))
(addif (< 0 rhs-cols) (gnc:make-html-table-cell/size
1 (+ mid-span rhs-cols) #f)))))
(addif (< 0 rhs-cols)
(gnc:make-html-table-cell/size
1 (+ mid-span rhs-cols)
(and add-derived-amounts-disclaimer?
(gnc:make-html-text
(G_ "* Amounts denoted thus are derived from, \
and do not match the transaction."))))))))

;; print grand total
(if (bal-col used-columns)
Expand Down Expand Up @@ -612,9 +610,9 @@
(split->reference lot-split)
(split->type-str lot-split payable?)
(splits->desc non-document)
(gnc:make-html-text (split->anchor lot-split #t))
(gnc:make-html-text (split->anchor lot-split #f))
(list->cell
(map (lambda (s) (split->anchor s #f)) non-document))
(map (lambda (s) (split->anchor s #t)) non-document))
(gncTransGetGUID lot-txn))
result))))

Expand All @@ -630,17 +628,16 @@
(lambda (posting-split)
(let* ((lot-txn-split (car lot-txn-splits))
(posting-txn (xaccSplitGetParent posting-split))
(document (gncInvoiceGetInvoiceFromTxn posting-txn))
(neg (gncInvoiceGetIsCreditNote document)))
(document (gncInvoiceGetInvoiceFromTxn posting-txn)))
(lp1 (cdr lot-txn-splits)
non-document
(cons (make-link-data
(qof-print-date (xaccTransGetDate posting-txn))
(split->reference posting-split)
(split->type-str posting-split payable?)
(splits->desc (list posting-split))
(gnc:make-html-text (split->anchor lot-split neg))
(gnc:make-html-text (split->anchor posting-split neg))
(gnc:make-html-text (split->anchor lot-split #f))
(gnc:make-html-text (split->anchor posting-split #f))
(gncInvoiceReturnGUID document))
result)))))

Expand All @@ -655,11 +652,10 @@

(define (payment-txn->payment-info txn)
(let lp ((splits (xaccTransGetAPARAcctSplitList txn #f))
(overpayment 0)
(invoices '())
(opposing-splits '()))
(match splits
(() (make-payment-info (AP-negate overpayment) invoices opposing-splits))
(() (make-payment-info invoices opposing-splits))
((split . rest)
(let ((lot (xaccSplitGetLot split)))
(define (equal-to-split? s) (equal? s split))
Expand All @@ -668,14 +664,12 @@
(opposing-splits opposing-splits))
(match lot-splits
(() (lp rest
(- overpayment (gnc-lot-get-balance lot))
invoices
opposing-splits))
(((? equal-to-split?) . tail) (lp1 tail opposing-splits))
((head . tail) (lp1 tail (cons head opposing-splits))))))
(inv
(lp rest
overpayment
(cons (cons inv split) invoices)
opposing-splits))))))))

Expand All @@ -689,15 +683,14 @@
(invoice->anchor (car inv-split-pair)))
(payment-info-invoices (payment-txn->payment-info txn)))))))

(define (make-payment->payee-table txn)
(define (make-payment->payee-table txn lhs-amount payable?)

(define payment-info (payment-txn->payment-info txn))

(define invoices-list
(define (invoices-list payment-info lhs-amount)
(let lp ((invoice-split-pairs (payment-info-invoices payment-info))
(result '()))
(result '())
(lhs-amount lhs-amount))
(match invoice-split-pairs
(() result)
(() (cons lhs-amount result))
(((inv . APAR-split) . rest)
(let* ((posting-split (lot-split->posting-split APAR-split)))
(lp rest
Expand All @@ -709,31 +702,58 @@
(gnc:make-html-text (split->anchor APAR-split #t))
(gnc:make-html-text (split->anchor posting-split #f))
(gncInvoiceReturnGUID inv))
result)))))))

(define overpayment-list
(let ((overpayment (payment-info-overpayment payment-info)))
(if (zero? overpayment)
'()
(list (make-link-desc-amount
(G_ "Pre-Payment")
(gnc:make-gnc-monetary currency overpayment)
(gncTransGetGUID txn))))))

(define payments-list
(map
(lambda (s)
(make-link-data
(qof-print-date (xaccTransGetDate (xaccSplitGetParent s)))
(split->reference s)
(split->type-str s payable?)
(splits->desc (list s))
(gnc:make-html-text (split->anchor s #f))
(gnc:make-html-text (split->anchor s #f))
(gncTransGetGUID (xaccSplitGetParent s))))
(payment-info-opposing-splits payment-info)))

(append invoices-list payments-list overpayment-list))
result)
(- lhs-amount (xaccSplitGetAmount APAR-split))))))))

(define (payments-list payment-info invoices-list-result)
(let lp1 ((opposing-splits (payment-info-opposing-splits payment-info))
(overpayment (car invoices-list-result))
(pmt-list (cdr invoices-list-result)))
(match opposing-splits
(() (reverse
(if (zero? overpayment)
pmt-list
(cons (make-link-desc-amount
(G_ "Pre-Payment")
(gnc:make-html-text
(gnc:monetary->string
(gnc:make-gnc-monetary
currency ((if payable? - +) overpayment))))
(gncTransGetGUID txn))
pmt-list))))
((s . rest)
(let* ((lot (xaccSplitGetLot s))
(sum
(fold
(lambda (a b) (if (equal? s a) b (+ b (xaccSplitGetAmount a))))
0 (gnc-lot-get-split-list lot)))
(lot-bal (gnc-lot-get-balance lot))
(lot-bal (if (sign-equal? lot-bal (xaccSplitGetAmount s)) 0 lot-bal))
(partial-amount (- sum lot-bal))
(paid? (zero? lot-bal)))
(unless paid?
(set! add-derived-amounts-disclaimer? #t))
(lp1 rest
(- overpayment partial-amount)
(cons
(make-link-data
(qof-print-date (xaccTransGetDate (xaccSplitGetParent s)))
(split->reference s)
(split->type-str s payable?)
(splits->desc (list s))
(gnc:make-html-text
(if paid? "" "* ")
(gnc:html-markup-anchor
(gnc:split-anchor-text s)
(gnc:monetary->string
(gnc:make-gnc-monetary currency partial-amount))))
(gnc:make-html-text (split->anchor s #f))
(gncTransGetGUID (xaccSplitGetParent s)))
pmt-list)))))))

(let* ((payment-info (payment-txn->payment-info txn))
(invoices-list-result (invoices-list payment-info lhs-amount)))
(payments-list payment-info invoices-list-result)))

(define (amount->anchor split amount)
(gnc:make-html-text
Expand Down Expand Up @@ -867,7 +887,7 @@
link-option
(case link-option
((simple) (make-payment->invoices-list txn))
((detailed) (make-payment->payee-table txn))
((detailed) (make-payment->payee-table txn orig-value payable?))
(else '(()))))

(lp printed? (not odd-row?) (cdr amt/next-pair) invalid-splits (+ total value)
Expand Down Expand Up @@ -1070,7 +1090,7 @@
(document (gnc:make-html-document))
(table (gnc:make-html-table))
(section-headings (make-section-heading-list used-columns owner-descr))
(headings (make-heading-list used-columns link-option acct-type))
(headings (make-heading-list used-columns link-option))
(report-title (string-append (G_ owner-descr) " " (G_ "Report"))))

(cond
Expand Down
25 changes: 19 additions & 6 deletions gnucash/report/reports/standard/test/test-owner-report.scm
View file
Expand Up @@ -39,12 +39,17 @@
(coverage-data->lcov data port)
(close port)))))

(define (teardown)
(gnc-clear-current-session))

(define (run-test-proper)
(let ((saved-format (qof-date-format-get)))
(qof-date-format-set QOF-DATE-FORMAT-ISO)
(test-runner-factory gnc:test-runner)
(test-begin "test-owner-report")
(owner-tests)
(test-group-with-cleanup "test-owner-report"
(owner-tests)
(teardown))
(qof-date-format-set saved-format)
(test-end "test-owner-report")))

Expand Down Expand Up @@ -333,14 +338,14 @@
owner-1 (get-acct "AR-USD")))
(sxml (options->sxml 'customer-new options "new-customer-report basic")))
(test-equal "inv-descriptions"
'("inv >90 $11.50" "$2.00" "inv 60-90 $7.50" "inv 30-60 $8.50"
'("inv >90 $11.50" "-$2.00" "inv 60-90 $7.50" "inv 30-60 $8.50"
"inv >90 payment" "inv >90 payment" "inv <30days $4.00"
"inv $200" "inv $200" "inv current $6.75" "inv $3 CN"
"$31.75" "$7.50")
((sxpath `(// (table 3) // tr (td 5) // *text*))
sxml))
(test-equal "credit-amounts"
'("$11.50" "$2.00" "$7.50" "$8.50" "$4.00" "$200.00" "$6.75" "$8.00")
'("$11.50" "-$2.00" "$7.50" "$8.50" "$4.00" "$200.00" "$6.75" "$8.00")
((sxpath `(// (table 3) // tr (td 6) // *text*))
sxml))
(test-equal "debit-amounts"
Expand All @@ -353,8 +358,8 @@
((sxpath `(// (table 3) // tr (td 8) // *text*))
sxml))
(test-equal "positive-link-amounts"
'("$1.50" "$2.00" "$8.00" "$7.50" "$8.50" "$11.50" "$11.50"
"$4.00" "$200.00" "$200.00" "$6.75")
'("-$1.50" "-$2.00" "$8.00" "$7.50" "$8.50" "$11.50" "$11.50"
"$4.00" "-$200.00" "$200.00" "$6.75")
((sxpath `(// (table 3) // tr
(td -1 (@ (equal? (class "number-cell")))) //
*text*))
Expand All @@ -370,7 +375,15 @@
(test-equal "aging-table"
'("$0.00" "$6.75" "$1.00" "$8.50" "$7.50" "$8.00" "$31.75")
((sxpath `(// (table 3) // (tr -1) // table // tbody // tr // *text*))
sxml)))
sxml))

(test-equal "dr/cr headers"
'("Date" "Due Date" "Reference" "Type" "Description"
"Debits" "Credits" "Balance" "Date" "Reference" "Type"
"Description" "Partial Amount" "Amount")
((sxpath `(// (table 3) // thead // (tr 2) // *text*))
sxml))
)
(test-end "new-customer-report")

(display "job-report tests:\n")
Expand Down

0 comments on commit c9fc781

Please sign in to comment.