Stuff
public text v1 · immutablethis is really ugly. sorry.
;; this is a new version of gnc:html-acct-table-add-accounts!
;; that is more efficient. it currently only supports:
;;
;; income-statement.scm
;;
;; hopefully others will follow.
;; okay, probably now supports all users.
;;
;; note that there is lots of dead code in here still that could be
;; cleaned out but is left for context and to be refactored into
;; the new code.
;;
;; It's messy but way faster.
;;
(define (gnc:html-acct-table-add-accounts! acct-table accounts)
;;
;; This is where most of the html-acct-table functionality ends up....
;;
;; This function traverses the (current) account tree, adding
;; information about the selected accounts to acct-table.
;;
;; helper for fetching values from the key/val environment alist
(define (get-val alist key)
(let ((lst (assoc-ref alist key)))
(if lst (car lst) lst)))
;; helper to plop <env> in the next available env cell
(define (add-row env)
(let ((html-table (gnc:_html-acct-table-matrix_ acct-table)))
(gnc:html-table-set-cell!
html-table
(gnc:html-table-num-rows html-table)
0
env)
)
)
(let* ((env (gnc:_html-acct-table-env_ acct-table))
;; establish all input parameters and their defaults
(depth-limit (let ((lim (get-val env 'display-tree-depth)))
(if (or (equal? lim 'unlimited)
(equal? lim 'all))
#f ;; BUG? other code expects integer here
lim)))
(limit-behavior (or (get-val env 'depth-limit-behavior) 'summarize))
(indent (or (get-val env 'initial-indent) 0))
(less-p (let ((pred (get-val env 'account-less-p)))
(if (equal? pred #t) gnc:account-code-less-p pred)))
(start-date (get-val env 'start-date))
(end-date (or (get-val env 'end-date)
(cons 'absolute (cons (current-time) 0))))
(report-commodity (or (get-val env 'report-commodity)
(gnc-default-report-currency)))
;; BUG: other code expects a real function here, maybe
;; someone was thinking price-source?
(exchange-fn (or (get-val env 'exchange-fn)
#f))
;;'weighted-average))
(column-header (let ((cell (get-val env 'column-header)))
(if (equal? cell #t)
(gnc:make-html-table-cell "Account name")
cell)))
(subtotal-mode (get-val env 'parent-account-subtotal-mode))
(zero-mode (let ((mode (get-val env 'zero-balance-mode)))
(or (if (equal? mode #t) 'show-leaf-acct mode)
'show-leaf-acct)
))
(label-mode (or (get-val env 'account-label-mode) 'anchor))
(balance-mode (or (get-val env 'balance-mode) 'post-closing))
(closing-pattern (or (get-val env 'closing-pattern)
(list
(list 'str (N_ "Closing Entries"))
(list 'cased #f)
(list 'regexp #f)
)
))
(adjusting-pattern (or (get-val env 'adjusting-pattern)
(list
(list 'str (N_ "Adjusting Entries"))
(list 'cased #f)
(list 'regexp #f)
)
))
;; local variables
(toplvl-accts
(gnc-account-get-children-sorted (gnc-get-current-root-account)))
(acct-depth-reached 0)
(logi-depth-reached (if depth-limit (- depth-limit 1) 0))
(disp-depth-reached 0)
)
;; the following function was adapted from html-utilities.scm
;;
;; needs to get its balance-mode functionality factored into
;; calculate balances below.
;; I left this in for reference.
;;
;; there's got to be a prettier way to do this. maybe even make two
;; of these. The balance-mode is only used by trial-balance.scm. so
;; make two versions of this animal, one that cares about balance-mode
;; one that doesn't. then check for a balance-mode !'post-closing and
;; call the right one. later.
(define (my-get-balance-nosub account start-date end-date)
(let* ((post-closing-bal
(if start-date
(gnc:account-get-comm-balance-interval
account start-date end-date #f)
(gnc:account-get-comm-balance-at-date
account end-date #f)))
(closing (lambda(a)
(gnc:account-get-trans-type-balance-interval
(list account) closing-pattern
start-date end-date)
)
)
(adjusting (lambda(a)
(gnc:account-get-trans-type-balance-interval
(list account) adjusting-pattern
start-date end-date)
)
)
)
;; what the heck is this? how about (case balance-mode blah...
(or (and (equal? balance-mode 'post-closing) post-closing-bal)
(and (equal? balance-mode 'pre-closing)
(let* ((closing-amt (closing account))
)
(post-closing-bal 'minusmerge closing-amt #f)
post-closing-bal)
)
(and (equal? balance-mode 'pre-adjusting)
(let* ((closing-amt (closing account))
(adjusting-amt (adjusting account))
)
(post-closing-bal 'minusmerge closing-amt #f)
(post-closing-bal 'minusmerge adjusting-amt #f)
post-closing-bal)
)
;; error if we get here.
)
)
)
;; helper to calculate the balances for all required accounts
;; currently ignores the *kind* of balance (i.e. balance-mode) to calculate
;; this is the function that doesn't work for the other reports that call the
;; original version of gnc:html-make-acct-table-add-accounts!
;; it needs to have that mess from my-get-balance-nosub factored into it
;; and then hopefully it will work for other reports.
;;
;; okay, warlord is always right. now we call my-get-balance-nosub to get the right
;; kind of balance.
(define (calculate-balances accts start-date end-date)
(if (not (null? accts))
(cons (cons (car accts) (if start-date
(begin
(display (list "returned balance for acct: " (car accts) " is "
(gnc:sum-collector-commodity (gnc:account-get-comm-balance-interval (ca\
r accts) start-date end-date #f) report-commodity exchange-fn)))
(newline)
(gnc:account-get-comm-balance-interval (car accts) start-date end-date #f)
)
(begin
(display (list "returned balance for acct: " (car accts) " is "
(gnc:sum-collector-commodity (gnc:account-get-comm-balance-at-date (car\
accts) end-date #f) report-commodity exchange-fn)))
(newline)
(gnc:account-get-comm-balance-at-date (car accts) end-date #f))))
;; using the existing function that cares about balance-mode
;; (my-get-balance-nosub (car accts) start-date end-date))
(calculate-balances (cdr accts) start-date end-date))
'()
)
)
(define (traverse-accounts! accts acct-depth logi-depth new-balances)
(define (use-acct? acct)
;; BUG? when depth-limit is not integer but boolean?
(and (or (equal? limit-behavior 'flatten) (< logi-depth depth-limit))
(member acct accounts)
)
)
;; helper function to return a cached balance from a list of
;; ( acct . balance ) cells
;; this should replace my-get-balance-no-sub in that it returns the
;; balance of an account when we don't care about the children
(define (get-balance acct-balances acct)
(if (not (null? acct-balances))
;; if the acct matches, return the appropriate balance
(if (equal? acct (caar acct-balances))
(cdar acct-balances)
;; otherwise, keep looking
(get-balance (cdr acct-balances) acct))
;; return a zero commodity collector
(gnc:make-commodity-collector)
)
)
;; Additional function that includes the subaccounts as
;; well. Note: It is necessary to define this here (instead of
;; changing an argument for account-get-balance) because the
;; use-acct? query is needed.
;;
;; not anymore. we only look at accounts we use. should move up one level.
(define (get-balance-sub acct-balances account)
;; this-collector for storing the result
(let ((this-collector
(get-balance acct-balances account)))
(for-each
(lambda (x) (if x (gnc-commodity-collector-merge this-collector x)))
(gnc:account-map-descendants
(lambda (a)
(get-balance acct-balances a ))
account))
this-collector))
(let ((disp-depth
(if (integer? depth-limit)
(min (- depth-limit 1) logi-depth)
logi-depth))
)
(for-each
(lambda (acct)
(let* ((subaccts (gnc-account-get-children 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 (or (and (equal? label-mode 'anchor)
account-anchor)
(and (equal? label-mode 'name)
(gnc:make-html-text account-name))
))
)
;; (display (list "the acct collector balance" report-comm-account-bal))(newline)
;; (display (list "the acct collector recursive balance" report-comm-recursive-bal))(newline)
(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))
(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)
(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))
)
))
(add-row row-env)
)
)
;; Recurse:
;; Dive into an account even if it isnt selected!
;; why? because some subaccts may be selected?
(traverse-accounts! subaccts
(+ acct-depth 1)
(if (use-acct? acct)
(+ logi-depth 1)
logi-depth)
new-balances)
;; after the return from recursion: subtotals
(or (not (use-acct? acct))
(not subtotal-mode)
;; ditto that remark concerning zero recursive-bal...
(and (gnc-commodity-collector-allzero? recursive-bal)
(equal? zero-mode 'omit-leaf-acct))
;; ignore use-acct for subtotals...?
;; (not (use-acct? acct))
(null? subaccts)
(let* ((lbl-txt (gnc:make-html-text (_ "Total") " ")))
(apply gnc:html-text-append! lbl-txt
(gnc:html-text-body label))
(if (equal? subtotal-mode 'canonically-tabbed)
(set! disp-depth (+ disp-depth 1))
(set! disp-depth-reached
(max disp-depth-reached disp-depth))
)
(set! row-env
(append grp-env
(list
(list 'account-label lbl-txt)
(list 'row-type 'subtotal-row)
(list 'display-depth disp-depth)
(list 'indented-depth
(+ disp-depth indent))
)
))
(add-row row-env)
)
)
)) ;; end of (lambda (acct) ...)
;; lambda is applied to each item in the (sorted) account list
(if less-p
(sort accts less-p)
accts)
) ;; end of for-each
)
) ;; end of definition of traverse-accounts!
;; do it
(let ((balance-table (calculate-balances accounts start-date end-date)))
(display balance-table)(newline)
(display "The balance-table BEFORE TRAVERSING!!!!")(newline)
(for-each
(lambda (x)
(if x (begin
(display (list (car x) (gnc:sum-collector-commodity (cdr x) report-commodity exchange-fn)))
(newline)
)
)
)
balance-table)
(traverse-accounts! toplvl-accts 0 0 balance-table)
(display "The balance-table AFTER TRAVERSING!!!!!")(newline)
(for-each
(lambda (x)
(if x (begin
(display (list (car x) (gnc:sum-collector-commodity (cdr x) report-commodity exchange-fn)))
(newline)
)
)
)
balance-table)
)