IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

[html-acct-table] compact traverse-accounts!

Browse Source 
* convert for-each to named-let
* allows reduction of set! calls
This commit is contained in:
Christopher Lam
2019-12-02 08:50:56 +08:00
parent ab20071d82
commit 8bf54ebfc1
1 changed files with 144 additions and 212 deletions
Download Patch File Download Diff File Expand all files Collapse all files

356
gnucash/report/report-system/html-acct-table.scm
View File

@@ -616,7 +616,6 @@
) )
;; the following function was adapted from html-utilities.scm ;; the following function was adapted from html-utilities.scm
;;
;; helper to calculate the balances for all required accounts ;; helper to calculate the balances for all required accounts
(define (calculate-balances accts start-date end-date get-balance-fn) (define (calculate-balances accts start-date end-date get-balance-fn)
@@ -673,19 +672,18 @@
(define (traverse-accounts! accts acct-depth logi-depth new-balances) (define (traverse-accounts! accts acct-depth logi-depth new-balances)
(define (use-acct? acct) (define (use-acct? acct)
;; BUG? when depth-limit is not integer but boolean? (and (or (eq? limit-behavior 'flatten)
(and (or (eq? limit-behavior 'flatten)
(< logi-depth depth-limit)) (< logi-depth depth-limit))
(member acct accounts))) (member acct accounts)))
;; helper function to return a cached balance from a list of ;; helper function to return a cached balance from a list of
;; ( acct . balance ) cells ;; ( acct . balance ) cells
(define (get-balance acct-balances acct) (define (get-balance acct-balances acct)
(let ((this-collector (gnc:make-commodity-collector)) (let ((this-collector (gnc:make-commodity-collector))
(acct-coll (hash-ref acct-balances (gncAccountGetGUID acct) (acct-coll (hash-ref acct-balances (gncAccountGetGUID acct)
(gnc:make-commodity-collector)))) (gnc:make-commodity-collector))))
(this-collector 'merge acct-coll #f) (this-collector 'merge acct-coll #f)
this-collector)) this-collector))
;; helper function that returns a cached balance from a list of ;; helper function that returns a cached balance from a list of
;; ( acct . balance) cells for the given account *and* its ;; ( acct . balance) cells for the given account *and* its
@@ -696,217 +694,151 @@
(lambda (acct) (lambda (acct)
(this-collector 'merge (get-balance acct-balances acct) #f)) (this-collector 'merge (get-balance acct-balances acct) #f))
(gnc:accounts-and-all-descendants (list account))) (gnc:accounts-and-all-descendants (list account)))
this-collector)) this-collector))
(let ((disp-depth (if (integer? depth-limit) (let lp ((accounts (if less-p (sort accts less-p) accts))
(min (- depth-limit 1) logi-depth) (row-added? #f)
logi-depth)) (disp-depth (if (integer? depth-limit)
(row-added? #f)) (min (1- depth-limit) logi-depth)
logi-depth)))
(for-each
(lambda (acct)
(let* ((subaccts (gnc-account-get-children-sorted acct))
;; assign output parameters
(account acct)
(account-name (xaccAccountGetName acct))
(account-code (xaccAccountGetCode acct))
(account-path (gnc-account-get-full-name acct))
(account-anchor (gnc:html-account-anchor acct))
(account-parent (gnc-account-get-parent acct))
(account-children subaccts)
(account-depth acct-depth)
(logical-depth logi-depth)
(account-commodity (xaccAccountGetCommodity acct))
(account-type (xaccAccountGetType acct))
;; N.B.: xaccAccountGetTypeStr really should be
;; called gnc:account-type-get-string
(account-type-string (xaccAccountGetTypeStr
(xaccAccountGetType acct)))
(account-guid (gncAccountGetGUID acct))
(account-description (xaccAccountGetDescription acct))
(account-notes (xaccAccountGetNotes acct))
;; These next two are commodity-collectors.
(account-bal (get-balance
new-balances acct))
(recursive-bal (get-balance-sub
new-balances acct))
;; These next two are of type <gnc:monetary>, right?
(report-comm-account-bal
(gnc:sum-collector-commodity
account-bal report-commodity exchange-fn))
(report-comm-recursive-bal
(gnc:sum-collector-commodity
recursive-bal report-commodity exchange-fn))
(grp-env
(append env
(list
(list 'initial-indent indent)
(list 'account account)
(list 'account-name account-name)
(list 'account-code account-code)
(list 'account-type account-type)
(list 'account-type-string account-type-string)
(list 'account-guid account-guid)
(list 'account-description account-description)
(list 'account-notes account-notes)
(list 'account-path account-path)
(list 'account-parent account-parent)
(list 'account-children account-children)
(list 'account-depth account-depth)
(list 'logical-depth logical-depth)
(list 'account-commodity account-commodity)
(list 'account-anchor account-anchor)
(list 'account-bal account-bal)
(list 'recursive-bal recursive-bal)
(list 'report-comm-account-bal
report-comm-account-bal)
(list 'report-comm-recursive-bal
report-comm-recursive-bal)
(list 'report-commodity report-commodity)
(list 'exchange-fn exchange-fn)
)))
(row-env #f)
(label (case label-mode
((anchor) account-anchor)
((name) (gnc:make-html-text account-name))))
(row #f)
(children-displayed? #f)
)
(set! acct-depth-reached (max acct-depth-reached acct-depth)) (cond
(set! logi-depth-reached (max logi-depth-reached logi-depth))
(set! disp-depth-reached (max disp-depth-reached disp-depth))
(or (not (use-acct? acct)) ((null? accounts) row-added?)
;; ok, so we'll consider parent accounts with zero
;; recursive-bal to be zero balance leaf accounts
(and (gnc-commodity-collector-allzero? recursive-bal)
(or (not report-budget)
(gnc-numeric-zero-p
(gnc:budget-account-get-rolledup-net
report-budget account #f #f)))
(equal? zero-mode 'omit-leaf-acct))
(begin
(set! row-env
(append grp-env
(list
(list 'account-label label)
(list 'row-type 'account-row)
(list 'display-depth disp-depth)
(list 'indented-depth
(+ disp-depth indent))
)
))
(set! row (add-row row-env))
)
)
;; Recurse:
;; Dive into an account even if it isn't selected!
;; why? because some subaccts may be selected.
(set! children-displayed?
(traverse-accounts! subaccts
(+ acct-depth 1)
(if (use-acct? acct)
(+ logi-depth 1)
logi-depth)
new-balances))
;; record whether any children were displayed (else
(if row (append-to-row row (list (list 'children-displayed? children-displayed?)))) (let* ((acct (car accounts))
(subaccts (gnc-account-get-children-sorted acct))
;; after the return from recursion: subtotals ;; These next two are commodity-collectors.
(or (not (use-acct? acct)) (account-bal (get-balance new-balances acct))
(not subtotal-mode) (recursive-bal (get-balance-sub new-balances acct))
;; ditto that remark concerning zero recursive-bal...
(and (gnc-commodity-collector-allzero? recursive-bal) ;; These next two are of type <gnc:monetary>
(equal? zero-mode 'omit-leaf-acct)) (report-comm-account-bal
;; ignore use-acct for subtotals...? (gnc:sum-collector-commodity
;; (not (use-acct? acct)) account-bal report-commodity exchange-fn))
(not children-displayed?) (report-comm-recursive-bal
(let* ((lbl-txt (gnc:make-html-text (_ "Total") " "))) (gnc:sum-collector-commodity
(apply gnc:html-text-append! lbl-txt recursive-bal report-commodity exchange-fn))
(gnc:html-text-body label))
(if (equal? subtotal-mode 'canonically-tabbed) (grp-env
(set! disp-depth (+ disp-depth 1)) (cons*
(set! disp-depth-reached (list 'initial-indent indent)
(max disp-depth-reached disp-depth)) (list 'account acct)
) (list 'account-name (xaccAccountGetName acct))
(set! row-env (list 'account-code (xaccAccountGetCode acct))
(append grp-env (list 'account-type (xaccAccountGetType acct))
(list (list 'account-type-string (xaccAccountGetTypeStr
(list 'account-label lbl-txt) (xaccAccountGetType acct)))
(list 'row-type 'subtotal-row) (list 'account-guid (gncAccountGetGUID acct))
(list 'display-depth disp-depth) (list 'account-description (xaccAccountGetDescription acct))
(list 'indented-depth (list 'account-notes (xaccAccountGetNotes acct))
(+ disp-depth indent)) (list 'account-path (gnc-account-get-full-name acct))
) (list 'account-parent (gnc-account-get-parent acct))
)) (list 'account-children subaccts)
(add-row row-env) (list 'account-depth acct-depth)
) (list 'logical-depth logi-depth)
) (list 'account-commodity (xaccAccountGetCommodity acct))
(if (or row-added? children-displayed? row) (set! row-added? #t)) (list 'account-anchor (gnc:html-account-anchor acct))
)) ;; end of (lambda (acct) ...) (list 'account-bal account-bal)
;; lambda is applied to each item in the (sorted) account list (list 'recursive-bal recursive-bal)
(if less-p (list 'report-comm-account-bal report-comm-account-bal)
(sort accts less-p) (list 'report-comm-recursive-bal report-comm-recursive-bal)
accts) (list 'report-commodity report-commodity)
) ;; end of for-each (list 'exchange-fn exchange-fn)
row-added? env))
) (label (case label-mode
) ;; end of definition of traverse-accounts! ((anchor) (gnc:html-account-anchor acct))
((name) (gnc:make-html-text (xaccAccountGetName acct)))))
(row #f)
(children-displayed? #f))
(set! acct-depth-reached (max acct-depth-reached acct-depth))
(set! logi-depth-reached (max logi-depth-reached logi-depth))
(set! disp-depth-reached (max disp-depth-reached disp-depth))
(unless (or (not (use-acct? acct))
;; ok, so we'll consider parent accounts with zero
;; recursive-bal to be zero balance leaf accounts
(and (gnc-commodity-collector-allzero? recursive-bal)
(eq? zero-mode 'omit-leaf-acct)
(or (not report-budget)
(zero? (gnc:budget-account-get-rolledup-net
report-budget acct #f #f)))))
(set! row
(add-row
(cons* (list 'account-label label)
(list 'row-type 'account-row)
(list 'display-depth disp-depth)
(list 'indented-depth (+ disp-depth indent))
grp-env))))
;; Recurse:
;; Dive into an account even if it isn't selected!
;; why? because some subaccts may be selected.
(set! children-displayed?
(traverse-accounts! subaccts
(1+ acct-depth)
(if (use-acct? acct)
(1+ logi-depth)
logi-depth)
new-balances))
;; record whether any children were displayed
(when row
(append-to-row
row (list (list 'children-displayed? children-displayed?))))
;; after the return from recursion: subtotals
(unless (or (not (use-acct? acct))
(not subtotal-mode)
(not children-displayed?)
(and (gnc-commodity-collector-allzero? recursive-bal)
(eq? zero-mode 'omit-leaf-acct)))
(let ((lbl-txt (gnc:make-html-text (_ "Total") " ")))
(apply gnc:html-text-append! lbl-txt (gnc:html-text-body label))
(if (eq? subtotal-mode 'canonically-tabbed)
(set! disp-depth (+ disp-depth 1))
(set! disp-depth-reached (max disp-depth-reached disp-depth)))
(add-row
(cons* (list 'account-label lbl-txt)
(list 'row-type 'subtotal-row)
(list 'display-depth disp-depth)
(list 'indented-depth (+ disp-depth indent))
grp-env))))
(lp (cdr accounts)
(or row-added? children-displayed? row)
disp-depth))))))
;; do it ;; do it
(traverse-accounts! toplvl-accts 0 0 (traverse-accounts!
(calculate-balances accounts start-date end-date get-balance-fn)) toplvl-accts 0 0
(calculate-balances accounts start-date end-date get-balance-fn))
;; now set the account-colspan entries ;; now set the account-colspan entries
;; he he... (let ((x 0)) (while (< x 5) (display x) (set! x (+ x 1)))) (let lp ((row 0)
;; now I know how to loop in scheme... yay! (rows (gnc:html-acct-table-num-rows acct-table)))
(let ((row 0) (when (< row rows)
(rows (gnc:html-acct-table-num-rows acct-table))) (let* ((orig-env (gnc:html-acct-table-get-row-env acct-table row))
(while (< row rows) (display-depth (get-val orig-env 'display-depth))
(let* ((orig-env (depth-limit (get-val orig-env 'display-tree-depth))
(gnc:html-acct-table-get-row-env acct-table row)) (indent (get-val orig-env 'initial-indent))
(display-depth (get-val orig-env 'display-depth)) (indented-depth (get-val orig-env 'indented-depth))
(depth-limit (get-val orig-env 'display-tree-depth)) (subtotal-mode (get-val orig-env 'parent-account-subtotal-mode))
(indent (get-val orig-env 'initial-indent)) (label-cols (+ disp-depth-reached 1))
(indented-depth (get-val orig-env 'indented-depth)) ;; these parameters *should* always, by now, be set...
(subtotal-mode (new-env
(get-val orig-env 'parent-account-subtotal-mode)) (cons*
(label-cols (+ disp-depth-reached 1)) (list 'account-colspan (- label-cols display-depth))
(logical-cols (if depth-limit (list 'label-cols label-cols)
(min (list 'account-cols (+ indent (max label-cols (or depth-limit 0))))
(+ logi-depth-reached 1) (list 'logical-cols (min (+ logi-depth-reached)
;; BUG? when depth-limit is not integer? (or depth-limit +inf.0)))
depth-limit) orig-env)))
(+ logi-depth-reached 1))) (gnc:html-acct-table-set-row-env! acct-table row new-env)
(colspan (- label-cols display-depth)) (lp (1+ row) rows))))))
;; these parameters *should* always, by now, be set...
(new-env
(append
orig-env
(list
(list 'account-colspan colspan)
(list 'label-cols label-cols)
(list 'logical-cols logical-cols)
(list 'account-cols
(+ indent
(max label-cols
(if depth-limit depth-limit 0)
)
)
)
)
))
)
(gnc:html-acct-table-set-row-env! acct-table row new-env)
(set! row (+ row 1))))
)
;; done
)
)
(define (gnc:html-acct-table-num-rows acct-table) (define (gnc:html-acct-table-num-rows acct-table)
(gnc:html-table-num-rows (gnc:_html-acct-table-matrix_ acct-table))) (gnc:html-table-num-rows (gnc:_html-acct-table-matrix_ acct-table)))