mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
[trep-engine.scm] upgrade engine to improve calculated-cells handling
calculated-cells was formerly a vector of RHS info - heading, calculator-fn, subtotal? etc. This upgrades it so that calculator-fn now accepts two arguments - split and transaction-row? which is a bool. It uses a basic record with version and list-of-cells, and each cell is a record (instead of a vector) with relevant members. This also enables the engine to handle previous calculated-cells -- note the income-gst-statement.scm will offer the previous one and will be transparently upgraded to the above -- see the function upgrade-to-calculated-cells-v2
This commit is contained in:
Christopher Lam
parent
49e34b5e03
commit
93dd19e98b
@ -56,6 +56,8 @@
|
|||||||
(gnucash report html-text))
|
(gnucash report html-text))
|
||||||
(use-modules (srfi srfi-11))
|
(use-modules (srfi srfi-11))
|
||||||
(use-modules (srfi srfi-1))
|
(use-modules (srfi srfi-1))
|
||||||
|
(use-modules (srfi srfi-9))
|
||||||
|
(use-modules (srfi srfi-26))
|
||||||
(use-modules (ice-9 match))
|
(use-modules (ice-9 match))
|
||||||
|
|
||||||
(export gnc:trep-options-generator)
|
(export gnc:trep-options-generator)
|
||||||
@ -992,6 +994,28 @@ be excluded from periodic reporting.")
|
|||||||
(GncOptionDBPtr-set-default-section options gnc:pagename-general)
|
(GncOptionDBPtr-set-default-section options gnc:pagename-general)
|
||||||
options))
|
options))
|
||||||
|
|
||||||
|
(define (upgrade-vector-to-assoclist list-of-columns)
|
||||||
|
(map (lambda (col)
|
||||||
|
(list (cons 'heading (vector-ref col 0))
|
||||||
|
(cons 'calc-fn (lambda (s tr?) ((vector-ref col 1) s)))
|
||||||
|
(cons 'reverse-column? (vector-ref col 2))
|
||||||
|
(cons 'subtotal? (vector-ref col 3))
|
||||||
|
(cons 'start-dual-column? (vector-ref col 4))
|
||||||
|
(cons 'friendly-heading-fn (vector-ref col 5))
|
||||||
|
;; the following is a backward-compatibility hack
|
||||||
|
;; being used by income-gst-statement.scm
|
||||||
|
(cons 'merge-dual-column? (and (<= 7 (vector-length col))
|
||||||
|
(vector-ref col 6)))))
|
||||||
|
list-of-columns))
|
||||||
|
|
||||||
|
(define (invalid-cell? cell)
|
||||||
|
(let lp ((fields '(heading calc-fn reverse-column? subtotal? start-dual-column?
|
||||||
|
friendly-heading-fn merge-dual-column?)))
|
||||||
|
(match fields
|
||||||
|
(() #f)
|
||||||
|
(((? (cut assq <> cell)) . rest) (lp rest))
|
||||||
|
((fld . _) (gnc:error "field " fld " missing in cell " cell) #t))))
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Here comes the big function that builds the whole table.
|
;; Here comes the big function that builds the whole table.
|
||||||
|
|
||||||
@ -1283,18 +1307,18 @@ be excluded from periodic reporting.")
|
|||||||
optname-currency)))
|
optname-currency)))
|
||||||
""))))
|
""))))
|
||||||
;; For conversion to row-currency.
|
;; For conversion to row-currency.
|
||||||
(converted-amount (lambda (s)
|
(converted-amount (lambda (s tr?)
|
||||||
(exchange-fn
|
(exchange-fn
|
||||||
(gnc:make-gnc-monetary (split-currency s)
|
(gnc:make-gnc-monetary (split-currency s)
|
||||||
(split-amount s))
|
(split-amount s))
|
||||||
(row-currency s)
|
(row-currency s)
|
||||||
(xaccTransGetDate (xaccSplitGetParent s)))))
|
(xaccTransGetDate (xaccSplitGetParent s)))))
|
||||||
(converted-debit-amount (lambda (s) (and (positive? (split-amount s))
|
(converted-debit-amount (lambda (s tr?) (and (positive? (split-amount s))
|
||||||
(converted-amount s))))
|
(converted-amount s tr?))))
|
||||||
(converted-credit-amount (lambda (s)
|
(converted-credit-amount (lambda (s tr?)
|
||||||
(and (not (positive? (split-amount s)))
|
(and (not (positive? (split-amount s)))
|
||||||
(gnc:monetary-neg (converted-amount s)))))
|
(gnc:monetary-neg (converted-amount s tr?)))))
|
||||||
(converted-account-balance (lambda (s)
|
(converted-account-balance (lambda (s tr?)
|
||||||
(exchange-fn
|
(exchange-fn
|
||||||
(gnc:make-gnc-monetary
|
(gnc:make-gnc-monetary
|
||||||
(split-currency s)
|
(split-currency s)
|
||||||
@ -1302,94 +1326,140 @@ be excluded from periodic reporting.")
|
|||||||
(row-currency s)
|
(row-currency s)
|
||||||
(time64CanonicalDayTime
|
(time64CanonicalDayTime
|
||||||
(xaccTransGetDate (xaccSplitGetParent s))))))
|
(xaccTransGetDate (xaccSplitGetParent s))))))
|
||||||
(original-amount (lambda (s)
|
(original-amount (lambda (s tr?)
|
||||||
(gnc:make-gnc-monetary
|
(gnc:make-gnc-monetary
|
||||||
(split-currency s) (split-amount s))))
|
(split-currency s) (split-amount s))))
|
||||||
(original-debit-amount (lambda (s)
|
(original-debit-amount (lambda (s tr?)
|
||||||
(and (positive? (split-amount s))
|
(and (positive? (split-amount s))
|
||||||
(original-amount s))))
|
(original-amount s tr?))))
|
||||||
(original-credit-amount (lambda (s)
|
(original-credit-amount (lambda (s tr?)
|
||||||
(and (not (positive? (split-amount s)))
|
(and (not (positive? (split-amount s)))
|
||||||
(gnc:monetary-neg (original-amount s)))))
|
(gnc:monetary-neg (original-amount s tr?)))))
|
||||||
(original-account-balance (lambda (s)
|
(original-account-balance (lambda (s tr?)
|
||||||
(gnc:make-gnc-monetary
|
(gnc:make-gnc-monetary
|
||||||
(split-currency s) (xaccSplitGetBalance s)))))
|
(split-currency s) (xaccSplitGetBalance s)))))
|
||||||
(append
|
(append
|
||||||
;; each column will be a vector
|
;; each column will be a list of pairs whose car is a metadata header,
|
||||||
;; (vector heading
|
;; and whose cdr is the procedure, string or bool to obtain the metadata
|
||||||
;; calculator-function (calculator-function split) to obtain amount
|
;; 'heading the heading string
|
||||||
;; reverse-column? #t to allow reverse signs
|
;; 'calc-fn (calc-fn split transaction-row?) to obtain gnc:monetary
|
||||||
;; subtotal? #t to allow subtotals (ie must be #f for
|
;; 'reverse-column? #t to allow reverse signs
|
||||||
;; running balance)
|
;; 'subtotal? #t to allow subtotals (ie must be #f for
|
||||||
;; start-dual-column? #t for the debit side of a dual column
|
;; running balance)
|
||||||
;; (i.e. debit/credit) which means the next
|
;; 'start-dual-column? #t for the debit side of a dual column
|
||||||
;; column must be the credit side
|
;; (i.e. debit/credit) which means the next
|
||||||
;; friendly-heading-fn (friendly-heading-fn account) to retrieve
|
;; column must be the credit side
|
||||||
;; friendly name for account debit/credit
|
;; 'friendly-heading-fn (friendly-heading-fn account) to retrieve
|
||||||
;; or 'bal-bf for balance-brought-forward
|
;; friendly name for account debit/credit
|
||||||
;; or 'original-bal-bf for bal-bf in original currency
|
;; or 'bal-bf for balance-brought-forward
|
||||||
;; when currency conversion is used
|
;; or 'original-bal-bf for bal-bf in original currency
|
||||||
;; start-dual-column? #t: merge with next cell for subtotal table.
|
;; when currency conversion is used
|
||||||
|
;; 'merge-dual-column? #t: merge with next cell.
|
||||||
|
|
||||||
(if (column-uses? 'amount-single)
|
(if (column-uses? 'amount-single)
|
||||||
(list (vector (header-commodity (G_ "Amount"))
|
(list (list (cons 'heading (header-commodity (G_ "Amount")))
|
||||||
converted-amount #t #t #f
|
(cons 'calc-fn converted-amount)
|
||||||
(lambda (a) "") #f))
|
(cons 'reverse-column? #t)
|
||||||
|
(cons 'subtotal? #t)
|
||||||
|
(cons 'start-dual-column? #f)
|
||||||
|
(cons 'friendly-heading-fn (const ""))
|
||||||
|
(cons 'merge-dual-column? #f)))
|
||||||
'())
|
'())
|
||||||
|
|
||||||
(if (column-uses? 'amount-double)
|
(if (column-uses? 'amount-double)
|
||||||
(list (vector (header-commodity (G_ "Debit"))
|
(list (list (cons 'heading (header-commodity (G_ "Debit")))
|
||||||
converted-debit-amount #f #t #t
|
(cons 'calc-fn converted-debit-amount)
|
||||||
friendly-debit #t)
|
(cons 'reverse-column? #f)
|
||||||
(vector (header-commodity (G_ "Credit"))
|
(cons 'subtotal? #t)
|
||||||
converted-credit-amount #f #t #f
|
(cons 'start-dual-column? #t)
|
||||||
friendly-credit #f))
|
(cons 'friendly-heading-fn friendly-debit)
|
||||||
|
(cons 'merge-dual-column? #t))
|
||||||
|
(list (cons 'heading (header-commodity (G_ "Credit")))
|
||||||
|
(cons 'calc-fn converted-credit-amount)
|
||||||
|
(cons 'reverse-column? #f)
|
||||||
|
(cons 'subtotal? #t)
|
||||||
|
(cons 'start-dual-column? #f)
|
||||||
|
(cons 'friendly-heading-fn friendly-credit)
|
||||||
|
(cons 'merge-dual-column? #f)))
|
||||||
'())
|
'())
|
||||||
|
|
||||||
(if (column-uses? 'running-balance)
|
(if (column-uses? 'running-balance)
|
||||||
(if show-bal-bf?
|
(if show-bal-bf?
|
||||||
(list (vector (header-commodity (G_ "Running Balance"))
|
(list (list (cons 'heading (header-commodity (G_ "Running Balance")))
|
||||||
converted-account-balance #t #f #f
|
(cons 'calc-fn converted-account-balance)
|
||||||
'bal-bf #f))
|
(cons 'reverse-column? #t)
|
||||||
(list (vector (header-commodity (G_ "Account Balance"))
|
(cons 'subtotal? #f)
|
||||||
converted-account-balance #t #f #f
|
(cons 'start-dual-column? #f)
|
||||||
#f #f)))
|
(cons 'friendly-heading-fn 'bal-bf)
|
||||||
|
(cons 'merge-dual-column? #f)))
|
||||||
|
(list (list (cons 'heading (header-commodity (G_ "Account Balance")))
|
||||||
|
(cons 'calc-fn converted-account-balance)
|
||||||
|
(cons 'reverse-column? #t)
|
||||||
|
(cons 'subtotal? #f)
|
||||||
|
(cons 'start-dual-column? #f)
|
||||||
|
(cons 'friendly-heading-fn #f)
|
||||||
|
(cons 'merge-dual-column? #f))))
|
||||||
'())
|
'())
|
||||||
|
|
||||||
(if (and (column-uses? 'amount-original-currency)
|
(if (and (column-uses? 'amount-original-currency)
|
||||||
(column-uses? 'amount-single))
|
(column-uses? 'amount-single))
|
||||||
(list (vector (G_ "Amount")
|
(list (list (cons 'heading (G_ "Amount"))
|
||||||
original-amount #t #t #f
|
(cons 'calc-fn original-amount)
|
||||||
(lambda (a) "") #f))
|
(cons 'reverse-column? #t)
|
||||||
|
(cons 'subtotal? #t)
|
||||||
|
(cons 'start-dual-column? #f)
|
||||||
|
(cons 'friendly-heading-fn (const ""))
|
||||||
|
(cons 'merge-dual-column? #f)))
|
||||||
'())
|
'())
|
||||||
|
|
||||||
(if (and (column-uses? 'amount-original-currency)
|
(if (and (column-uses? 'amount-original-currency)
|
||||||
(column-uses? 'amount-double))
|
(column-uses? 'amount-double))
|
||||||
(list (vector (G_ "Debit")
|
(list (list (cons 'heading (G_ "Debit"))
|
||||||
original-debit-amount #f #t #t
|
(cons 'calc-fn original-debit-amount)
|
||||||
friendly-debit #t)
|
(cons 'reverse-column? #f)
|
||||||
(vector (G_ "Credit")
|
(cons 'subtotal? #t)
|
||||||
original-credit-amount #f #t #f
|
(cons 'start-dual-column? #t)
|
||||||
friendly-credit #f))
|
(cons 'friendly-heading-fn friendly-debit)
|
||||||
|
(cons 'merge-dual-column? #t))
|
||||||
|
(list (cons 'heading (G_ "Credit"))
|
||||||
|
(cons 'calc-fn original-credit-amount)
|
||||||
|
(cons 'reverse-column? #f)
|
||||||
|
(cons 'subtotal? #t)
|
||||||
|
(cons 'start-dual-column? #f)
|
||||||
|
(cons 'friendly-heading-fn friendly-credit)
|
||||||
|
(cons 'merge-dual-column? #f)))
|
||||||
'())
|
'())
|
||||||
|
|
||||||
(if (and (column-uses? 'amount-original-currency)
|
(if (and (column-uses? 'amount-original-currency)
|
||||||
(column-uses? 'running-balance))
|
(column-uses? 'running-balance))
|
||||||
(if show-bal-bf?
|
(if show-bal-bf?
|
||||||
(list (vector (G_ "Running Balance")
|
(list (list (cons 'heading (G_ "Running Balance"))
|
||||||
original-account-balance #t #f #f
|
(cons 'calc-fn original-account-balance)
|
||||||
'original-bal-bf #f))
|
(cons 'reverse-column? #t)
|
||||||
(list (vector (G_ "Account Balance")
|
(cons 'subtotal? #f)
|
||||||
original-account-balance #t #f #f
|
(cons 'start-dual-column? #f)
|
||||||
#f #f)))
|
(cons 'friendly-heading-fn 'original-bal-bf)
|
||||||
|
(cons 'merge-dual-column? #f)))
|
||||||
|
(list (list (cons 'heading (G_ "Account Balance"))
|
||||||
|
(cons 'calc-fn original-account-balance)
|
||||||
|
(cons 'reverse-column? #t)
|
||||||
|
(cons 'subtotal? #f)
|
||||||
|
(cons 'start-dual-column? #f)
|
||||||
|
(cons 'friendly-heading-fn #f)
|
||||||
|
(cons 'merge-dual-column? #f))))
|
||||||
'()))))
|
'()))))
|
||||||
|
|
||||||
(define calculated-cells
|
(define calculated-cells
|
||||||
;; this part will check whether custom-calculated-cells were specified. this
|
;; this part will check whether custom-calculated-cells were specified. this
|
||||||
;; describes a custom function which consumes an options list, and generates
|
;; describes a custom function which consumes an options list, and generates
|
||||||
;; a vectorlist similar to default-calculated-cells as above.
|
;; an association list similar to default-calculated-cells as above.
|
||||||
(if custom-calculated-cells
|
(if custom-calculated-cells
|
||||||
(custom-calculated-cells options)
|
(let ((cc (custom-calculated-cells options)))
|
||||||
|
(cond
|
||||||
|
((not (pair? cc)) (gnc:error "welp" cc) default-calculated-cells)
|
||||||
|
((vector? (car cc)) (upgrade-vector-to-assoclist cc))
|
||||||
|
((any invalid-cell? cc) (gnc:error "welp" cc) default-calculated-cells)
|
||||||
|
(else cc)))
|
||||||
default-calculated-cells))
|
default-calculated-cells))
|
||||||
|
|
||||||
(define headings-left-columns
|
(define headings-left-columns
|
||||||
@ -1398,9 +1468,7 @@ be excluded from periodic reporting.")
|
|||||||
left-columns))
|
left-columns))
|
||||||
|
|
||||||
(define headings-right-columns
|
(define headings-right-columns
|
||||||
(map (lambda (column)
|
(map (cut assq-ref <> 'heading) calculated-cells))
|
||||||
(vector-ref column 0))
|
|
||||||
calculated-cells))
|
|
||||||
|
|
||||||
(define width-left-columns (length left-columns))
|
(define width-left-columns (length left-columns))
|
||||||
(define width-right-columns (length calculated-cells))
|
(define width-right-columns (length calculated-cells))
|
||||||
@ -1423,7 +1491,7 @@ be excluded from periodic reporting.")
|
|||||||
(case level
|
(case level
|
||||||
((primary) optname-prime-sortkey)
|
((primary) optname-prime-sortkey)
|
||||||
((secondary) optname-sec-sortkey))))
|
((secondary) optname-sec-sortkey))))
|
||||||
(data (if (and (any (lambda (c) (eq? 'bal-bf (vector-ref c 5)))
|
(data (if (and (any (lambda (c) (eq? 'bal-bf (assq-ref c 'friendly-heading-fn)))
|
||||||
calculated-cells)
|
calculated-cells)
|
||||||
(memq sortkey ACCOUNT-SORTING-TYPES))
|
(memq sortkey ACCOUNT-SORTING-TYPES))
|
||||||
;; Translators: Balance b/f stands for "Balance
|
;; Translators: Balance b/f stands for "Balance
|
||||||
@ -1453,7 +1521,7 @@ be excluded from periodic reporting.")
|
|||||||
1 (+ right-indent width-left-columns) "total-label-cell" data)))
|
1 (+ right-indent width-left-columns) "total-label-cell" data)))
|
||||||
(map
|
(map
|
||||||
(lambda (cell)
|
(lambda (cell)
|
||||||
(match (vector-ref cell 5)
|
(match (assq-ref cell 'friendly-heading-fn)
|
||||||
(#f #f)
|
(#f #f)
|
||||||
('bal-bf
|
('bal-bf
|
||||||
(let* ((acc (xaccSplitGetAccount split))
|
(let* ((acc (xaccSplitGetAccount split))
|
||||||
@ -1488,14 +1556,10 @@ be excluded from periodic reporting.")
|
|||||||
(fn (xaccSplitGetAccount split))))))))
|
(fn (xaccSplitGetAccount split))))))))
|
||||||
calculated-cells))))))
|
calculated-cells))))))
|
||||||
|
|
||||||
;; check first calculated-cell vector's 7th cell. originally these
|
;; check first calculated-cell merge-dual-column status.
|
||||||
;; had only 6 cells. backward-compatible upgrade. useful for the
|
|
||||||
;; next function, add-subtotal-row.
|
|
||||||
(define first-column-merge?
|
(define first-column-merge?
|
||||||
(let ((first-cell (and (pair? calculated-cells) (car calculated-cells))))
|
(and (pair? calculated-cells)
|
||||||
(and first-cell
|
(assq-ref (car calculated-cells) 'merge-dual-column?)))
|
||||||
(<= 7 (vector-length first-cell))
|
|
||||||
(vector-ref first-cell 6))))
|
|
||||||
|
|
||||||
(define (add-subtotal-row subtotal-string subtotal-collectors
|
(define (add-subtotal-row subtotal-string subtotal-collectors
|
||||||
subtotal-style level row col)
|
subtotal-style level row col)
|
||||||
@ -1504,7 +1568,7 @@ be excluded from periodic reporting.")
|
|||||||
((primary) primary-indent)
|
((primary) primary-indent)
|
||||||
((secondary) (+ primary-indent secondary-indent))))
|
((secondary) (+ primary-indent secondary-indent))))
|
||||||
(right-indent (- indent-level left-indent))
|
(right-indent (- indent-level left-indent))
|
||||||
(merge-list (map (lambda (cell) (vector-ref cell 4)) calculated-cells))
|
(merge-list (map (cut assq-ref <> 'start-dual-column?) calculated-cells))
|
||||||
(columns (map (lambda (coll)
|
(columns (map (lambda (coll)
|
||||||
(coll 'format gnc:make-gnc-monetary #f))
|
(coll 'format gnc:make-gnc-monetary #f))
|
||||||
subtotal-collectors))
|
subtotal-collectors))
|
||||||
@ -1688,8 +1752,10 @@ be excluded from periodic reporting.")
|
|||||||
split transaction-row?))
|
split transaction-row?))
|
||||||
left-columns)
|
left-columns)
|
||||||
(map (lambda (cell)
|
(map (lambda (cell)
|
||||||
(let* ((cell-monetary ((vector-ref cell 1) split))
|
(let* ((cell-monetary ((assq-ref cell 'calc-fn)
|
||||||
(reverse? (and (vector-ref cell 2) reversible-account?))
|
split transaction-row?))
|
||||||
|
(reverse? (and (assq-ref cell 'reverse-column?)
|
||||||
|
reversible-account?))
|
||||||
(cell-content (and cell-monetary
|
(cell-content (and cell-monetary
|
||||||
(if reverse?
|
(if reverse?
|
||||||
(gnc:monetary-neg cell-monetary)
|
(gnc:monetary-neg cell-monetary)
|
||||||
@ -1702,7 +1768,9 @@ be excluded from periodic reporting.")
|
|||||||
cell-content)))))
|
cell-content)))))
|
||||||
cell-calculators))))
|
cell-calculators))))
|
||||||
|
|
||||||
(map (lambda (cell) (and (vector-ref cell 3) ((vector-ref cell 1) split)))
|
(map (lambda (cell)
|
||||||
|
(and (assq-ref cell 'subtotal?)
|
||||||
|
((assq-ref cell 'calc-fn) split transaction-row?)))
|
||||||
cell-calculators)))
|
cell-calculators)))
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
@ -1856,14 +1924,14 @@ be excluded from periodic reporting.")
|
|||||||
(loop rest (not odd-row?) (1+ work-done)))))
|
(loop rest (not odd-row?) (1+ work-done)))))
|
||||||
|
|
||||||
(let ((csvlist (cond
|
(let ((csvlist (cond
|
||||||
((any (lambda (cell) (vector-ref cell 4)) calculated-cells)
|
((any (cut assq-ref <> 'start-dual-column?) calculated-cells)
|
||||||
;; there are mergeable cells. don't return a list.
|
;; there are mergeable cells. don't return a list.
|
||||||
(N_ "CSV disabled for double column amounts"))
|
(N_ "CSV disabled for double column amounts"))
|
||||||
|
|
||||||
(else
|
(else
|
||||||
(map
|
(map
|
||||||
(lambda (cell coll)
|
(lambda (cell coll)
|
||||||
(cons (vector-ref cell 0)
|
(cons (assq-ref cell 'heading)
|
||||||
(coll 'format gnc:make-gnc-monetary #f)))
|
(coll 'format gnc:make-gnc-monetary #f)))
|
||||||
calculated-cells total-collectors)))))
|
calculated-cells total-collectors)))))
|
||||||
(values table grid csvlist))))
|
(values table grid csvlist))))
|
||||||
@ -1964,7 +2032,7 @@ be excluded from periodic reporting.")
|
|||||||
;; the report object
|
;; the report object
|
||||||
;;
|
;;
|
||||||
;; the optional arguments are:
|
;; the optional arguments are:
|
||||||
;; #:custom-calculated-cells - a list of vectors to define customized data columns
|
;; #:custom-calculated-cells - a list of pairs to define customized data columns
|
||||||
;; #:empty-report-message - a str or html-object displayed at the initial run
|
;; #:empty-report-message - a str or html-object displayed at the initial run
|
||||||
;; #:custom-split-filter - a split->bool function to add to the split filter
|
;; #:custom-split-filter - a split->bool function to add to the split filter
|
||||||
;; #:split->date - a split->time64 which overrides the default posted date filter
|
;; #:split->date - a split->time64 which overrides the default posted date filter
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user