mirror of
https://github.com/Gnucash/gnucash.git
synced 2024-11-25 10:20:18 -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))
|
||||
(use-modules (srfi srfi-11))
|
||||
(use-modules (srfi srfi-1))
|
||||
(use-modules (srfi srfi-9))
|
||||
(use-modules (srfi srfi-26))
|
||||
(use-modules (ice-9 match))
|
||||
|
||||
(export gnc:trep-options-generator)
|
||||
@ -992,6 +994,28 @@ be excluded from periodic reporting.")
|
||||
(GncOptionDBPtr-set-default-section options gnc:pagename-general)
|
||||
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.
|
||||
|
||||
@ -1283,18 +1307,18 @@ be excluded from periodic reporting.")
|
||||
optname-currency)))
|
||||
""))))
|
||||
;; For conversion to row-currency.
|
||||
(converted-amount (lambda (s)
|
||||
(converted-amount (lambda (s tr?)
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary (split-currency s)
|
||||
(split-amount s))
|
||||
(row-currency s)
|
||||
(xaccTransGetDate (xaccSplitGetParent s)))))
|
||||
(converted-debit-amount (lambda (s) (and (positive? (split-amount s))
|
||||
(converted-amount s))))
|
||||
(converted-credit-amount (lambda (s)
|
||||
(converted-debit-amount (lambda (s tr?) (and (positive? (split-amount s))
|
||||
(converted-amount s tr?))))
|
||||
(converted-credit-amount (lambda (s tr?)
|
||||
(and (not (positive? (split-amount s)))
|
||||
(gnc:monetary-neg (converted-amount s)))))
|
||||
(converted-account-balance (lambda (s)
|
||||
(gnc:monetary-neg (converted-amount s tr?)))))
|
||||
(converted-account-balance (lambda (s tr?)
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary
|
||||
(split-currency s)
|
||||
@ -1302,94 +1326,140 @@ be excluded from periodic reporting.")
|
||||
(row-currency s)
|
||||
(time64CanonicalDayTime
|
||||
(xaccTransGetDate (xaccSplitGetParent s))))))
|
||||
(original-amount (lambda (s)
|
||||
(original-amount (lambda (s tr?)
|
||||
(gnc:make-gnc-monetary
|
||||
(split-currency s) (split-amount s))))
|
||||
(original-debit-amount (lambda (s)
|
||||
(original-debit-amount (lambda (s tr?)
|
||||
(and (positive? (split-amount s))
|
||||
(original-amount s))))
|
||||
(original-credit-amount (lambda (s)
|
||||
(original-amount s tr?))))
|
||||
(original-credit-amount (lambda (s tr?)
|
||||
(and (not (positive? (split-amount s)))
|
||||
(gnc:monetary-neg (original-amount s)))))
|
||||
(original-account-balance (lambda (s)
|
||||
(gnc:monetary-neg (original-amount s tr?)))))
|
||||
(original-account-balance (lambda (s tr?)
|
||||
(gnc:make-gnc-monetary
|
||||
(split-currency s) (xaccSplitGetBalance s)))))
|
||||
(append
|
||||
;; each column will be a vector
|
||||
;; (vector heading
|
||||
;; calculator-function (calculator-function split) to obtain amount
|
||||
;; reverse-column? #t to allow reverse signs
|
||||
;; subtotal? #t to allow subtotals (ie must be #f for
|
||||
;; running balance)
|
||||
;; start-dual-column? #t for the debit side of a dual column
|
||||
;; (i.e. debit/credit) which means the next
|
||||
;; column must be the credit side
|
||||
;; friendly-heading-fn (friendly-heading-fn account) to retrieve
|
||||
;; friendly name for account debit/credit
|
||||
;; or 'bal-bf for balance-brought-forward
|
||||
;; or 'original-bal-bf for bal-bf in original currency
|
||||
;; when currency conversion is used
|
||||
;; start-dual-column? #t: merge with next cell for subtotal table.
|
||||
;; each column will be a list of pairs whose car is a metadata header,
|
||||
;; and whose cdr is the procedure, string or bool to obtain the metadata
|
||||
;; 'heading the heading string
|
||||
;; 'calc-fn (calc-fn split transaction-row?) to obtain gnc:monetary
|
||||
;; 'reverse-column? #t to allow reverse signs
|
||||
;; 'subtotal? #t to allow subtotals (ie must be #f for
|
||||
;; running balance)
|
||||
;; 'start-dual-column? #t for the debit side of a dual column
|
||||
;; (i.e. debit/credit) which means the next
|
||||
;; column must be the credit side
|
||||
;; 'friendly-heading-fn (friendly-heading-fn account) to retrieve
|
||||
;; friendly name for account debit/credit
|
||||
;; or 'bal-bf for balance-brought-forward
|
||||
;; or 'original-bal-bf for bal-bf in original currency
|
||||
;; when currency conversion is used
|
||||
;; 'merge-dual-column? #t: merge with next cell.
|
||||
|
||||
(if (column-uses? 'amount-single)
|
||||
(list (vector (header-commodity (G_ "Amount"))
|
||||
converted-amount #t #t #f
|
||||
(lambda (a) "") #f))
|
||||
(list (list (cons 'heading (header-commodity (G_ "Amount")))
|
||||
(cons 'calc-fn converted-amount)
|
||||
(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)
|
||||
(list (vector (header-commodity (G_ "Debit"))
|
||||
converted-debit-amount #f #t #t
|
||||
friendly-debit #t)
|
||||
(vector (header-commodity (G_ "Credit"))
|
||||
converted-credit-amount #f #t #f
|
||||
friendly-credit #f))
|
||||
(list (list (cons 'heading (header-commodity (G_ "Debit")))
|
||||
(cons 'calc-fn converted-debit-amount)
|
||||
(cons 'reverse-column? #f)
|
||||
(cons 'subtotal? #t)
|
||||
(cons 'start-dual-column? #t)
|
||||
(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 show-bal-bf?
|
||||
(list (vector (header-commodity (G_ "Running Balance"))
|
||||
converted-account-balance #t #f #f
|
||||
'bal-bf #f))
|
||||
(list (vector (header-commodity (G_ "Account Balance"))
|
||||
converted-account-balance #t #f #f
|
||||
#f #f)))
|
||||
(list (list (cons 'heading (header-commodity (G_ "Running Balance")))
|
||||
(cons 'calc-fn converted-account-balance)
|
||||
(cons 'reverse-column? #t)
|
||||
(cons 'subtotal? #f)
|
||||
(cons 'start-dual-column? #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)
|
||||
(column-uses? 'amount-single))
|
||||
(list (vector (G_ "Amount")
|
||||
original-amount #t #t #f
|
||||
(lambda (a) "") #f))
|
||||
(list (list (cons 'heading (G_ "Amount"))
|
||||
(cons 'calc-fn original-amount)
|
||||
(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)
|
||||
(column-uses? 'amount-double))
|
||||
(list (vector (G_ "Debit")
|
||||
original-debit-amount #f #t #t
|
||||
friendly-debit #t)
|
||||
(vector (G_ "Credit")
|
||||
original-credit-amount #f #t #f
|
||||
friendly-credit #f))
|
||||
(list (list (cons 'heading (G_ "Debit"))
|
||||
(cons 'calc-fn original-debit-amount)
|
||||
(cons 'reverse-column? #f)
|
||||
(cons 'subtotal? #t)
|
||||
(cons 'start-dual-column? #t)
|
||||
(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)
|
||||
(column-uses? 'running-balance))
|
||||
(if show-bal-bf?
|
||||
(list (vector (G_ "Running Balance")
|
||||
original-account-balance #t #f #f
|
||||
'original-bal-bf #f))
|
||||
(list (vector (G_ "Account Balance")
|
||||
original-account-balance #t #f #f
|
||||
#f #f)))
|
||||
(list (list (cons 'heading (G_ "Running Balance"))
|
||||
(cons 'calc-fn original-account-balance)
|
||||
(cons 'reverse-column? #t)
|
||||
(cons 'subtotal? #f)
|
||||
(cons 'start-dual-column? #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
|
||||
;; this part will check whether custom-calculated-cells were specified. this
|
||||
;; 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
|
||||
(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))
|
||||
|
||||
(define headings-left-columns
|
||||
@ -1398,9 +1468,7 @@ be excluded from periodic reporting.")
|
||||
left-columns))
|
||||
|
||||
(define headings-right-columns
|
||||
(map (lambda (column)
|
||||
(vector-ref column 0))
|
||||
calculated-cells))
|
||||
(map (cut assq-ref <> 'heading) calculated-cells))
|
||||
|
||||
(define width-left-columns (length left-columns))
|
||||
(define width-right-columns (length calculated-cells))
|
||||
@ -1423,7 +1491,7 @@ be excluded from periodic reporting.")
|
||||
(case level
|
||||
((primary) optname-prime-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)
|
||||
(memq sortkey ACCOUNT-SORTING-TYPES))
|
||||
;; 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)))
|
||||
(map
|
||||
(lambda (cell)
|
||||
(match (vector-ref cell 5)
|
||||
(match (assq-ref cell 'friendly-heading-fn)
|
||||
(#f #f)
|
||||
('bal-bf
|
||||
(let* ((acc (xaccSplitGetAccount split))
|
||||
@ -1488,14 +1556,10 @@ be excluded from periodic reporting.")
|
||||
(fn (xaccSplitGetAccount split))))))))
|
||||
calculated-cells))))))
|
||||
|
||||
;; check first calculated-cell vector's 7th cell. originally these
|
||||
;; had only 6 cells. backward-compatible upgrade. useful for the
|
||||
;; next function, add-subtotal-row.
|
||||
;; check first calculated-cell merge-dual-column status.
|
||||
(define first-column-merge?
|
||||
(let ((first-cell (and (pair? calculated-cells) (car calculated-cells))))
|
||||
(and first-cell
|
||||
(<= 7 (vector-length first-cell))
|
||||
(vector-ref first-cell 6))))
|
||||
(and (pair? calculated-cells)
|
||||
(assq-ref (car calculated-cells) 'merge-dual-column?)))
|
||||
|
||||
(define (add-subtotal-row subtotal-string subtotal-collectors
|
||||
subtotal-style level row col)
|
||||
@ -1504,7 +1568,7 @@ be excluded from periodic reporting.")
|
||||
((primary) primary-indent)
|
||||
((secondary) (+ primary-indent secondary-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)
|
||||
(coll 'format gnc:make-gnc-monetary #f))
|
||||
subtotal-collectors))
|
||||
@ -1688,8 +1752,10 @@ be excluded from periodic reporting.")
|
||||
split transaction-row?))
|
||||
left-columns)
|
||||
(map (lambda (cell)
|
||||
(let* ((cell-monetary ((vector-ref cell 1) split))
|
||||
(reverse? (and (vector-ref cell 2) reversible-account?))
|
||||
(let* ((cell-monetary ((assq-ref cell 'calc-fn)
|
||||
split transaction-row?))
|
||||
(reverse? (and (assq-ref cell 'reverse-column?)
|
||||
reversible-account?))
|
||||
(cell-content (and cell-monetary
|
||||
(if reverse?
|
||||
(gnc:monetary-neg cell-monetary)
|
||||
@ -1702,7 +1768,9 @@ be excluded from periodic reporting.")
|
||||
cell-content)))))
|
||||
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)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@ -1856,14 +1924,14 @@ be excluded from periodic reporting.")
|
||||
(loop rest (not odd-row?) (1+ work-done)))))
|
||||
|
||||
(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.
|
||||
(N_ "CSV disabled for double column amounts"))
|
||||
|
||||
(else
|
||||
(map
|
||||
(lambda (cell coll)
|
||||
(cons (vector-ref cell 0)
|
||||
(cons (assq-ref cell 'heading)
|
||||
(coll 'format gnc:make-gnc-monetary #f)))
|
||||
calculated-cells total-collectors)))))
|
||||
(values table grid csvlist))))
|
||||
@ -1964,7 +2032,7 @@ be excluded from periodic reporting.")
|
||||
;; the report object
|
||||
;;
|
||||
;; 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
|
||||
;; #: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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user