gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Thu Jan 2 05:21:36 EST 2020
Updated via https://github.com/Gnucash/gnucash/commit/3d05f78c (commit)
via https://github.com/Gnucash/gnucash/commit/0397aca1 (commit)
via https://github.com/Gnucash/gnucash/commit/f3499686 (commit)
from https://github.com/Gnucash/gnucash/commit/795fe9aa (commit)
commit 3d05f78caf53f774737954912ee86a815cdd32a3
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Dec 28 22:57:24 2019 +0700
[new-owner-report] add double-header
also create a num-cols function which returns an appropriate number of
cols for various report sections.
diff --git a/gnucash/report/business-reports/new-owner-report.scm b/gnucash/report/business-reports/new-owner-report.scm
index b83854ed4..fc337e8c0 100644
--- a/gnucash/report/business-reports/new-owner-report.scm
+++ b/gnucash/report/business-reports/new-owner-report.scm
@@ -131,16 +131,30 @@
(vector-ref columns-used 8))
(define (bal-col columns-used)
(vector-ref columns-used 9))
-(define (num-link-cols columns-used)
- (+ (if (or (date-col columns-used) (type-col columns-used)
- (ref-col columns-used) (credit-col columns-used)
- (desc-col columns-used) (debit-col columns-used))
- 1 0)
- (if (date-col columns-used) 1 0)
- (if (ref-col columns-used) 1 0)
- (if (type-col columns-used) 1 0)
- (if (desc-col columns-used) 1 0)
- (if (or (credit-col columns-used) (debit-col columns-used)) 1 0)))
+
+(define (num-cols columns-used section)
+ (let* ((date? (date-col columns-used))
+ (due? (date-due-col columns-used))
+ (ref? (ref-col columns-used))
+ (type? (type-col columns-used))
+ (desc? (desc-col columns-used))
+ (sale? (sale-col columns-used))
+ (tax? (tax-col columns-used))
+ (credit? (credit-col columns-used))
+ (debit? (debit-col columns-used))
+ (bal? (bal-col columns-used))
+ (spacer? (or date? type? ref? desc? debit? credit?))
+ (amt? (or credit? debit?))
+ (cols-alist
+ (list
+ (list 'lhs-cols date? due? ref? type? desc? sale? tax? credit? debit? bal?)
+ (list 'ptt-span date? due? ref? type? desc?)
+ (list 'mid-spac spacer?)
+ (list 'rhs-cols date? ref? type? desc? amt?)
+ (list 'rhs-span date? ref? type? desc?)))
+ (cols-list (assq-ref cols-alist section)))
+ (count identity cols-list)))
+
(define columns-used-size 10)
(define (build-column-used options)
@@ -196,10 +210,7 @@
((simple)
(addto! heading-list (_ linked-txns-header)))
((detailed)
- (if (or (date-col column-vector) (type-col column-vector)
- (ref-col column-vector) (credit-col column-vector)
- (desc-col column-vector) (debit-col column-vector))
- (addto! heading-list #f))
+ (if (< 0 (num-cols column-vector 'mid-spac)) (addto! heading-list #f))
(if (date-col column-vector) (addto! heading-list (_ "Date")))
(if (ref-col column-vector) (addto! heading-list (_ "Reference")))
(if (type-col column-vector) (addto! heading-list (_ "Type")))
@@ -295,18 +306,24 @@
(define-syntax-rule (addif pred? elt)
(if pred? (list elt) '()))
+(define (make-section-heading-list column-vector owner-desc)
+ (define (make-heading cols str)
+ (gnc:make-html-table-cell/size/markup 1 cols "th" str))
+ (let ((lhs (num-cols column-vector 'lhs-cols))
+ (mid (num-cols column-vector 'mid-spac))
+ (rhs (num-cols column-vector 'rhs-cols)))
+ (append
+ ;; Translators: ~a History refers to main details table in owner
+ ;; report. ~a will be replaced with Customer, Vendor or Employee.
+ (addif (< 0 lhs) (make-heading lhs (format #f (_ "~a History") owner-desc)) )
+ (addif (< 0 mid) (make-heading mid #f))
+ (addif (< 0 rhs) (make-heading rhs (_ "Linked Details"))))))
;;
;; Make a row list based on the visible columns
;;
(define (add-row table odd-row? column-vector date due-date ref type-str
desc currency amt credit debit sale tax anchor-split
link-option link-rows)
- (define empty-cols
- (count identity
- (map (lambda (f) (f column-vector))
- (list date-col date-due-col ref-col type-col
- desc-col sale-col tax-col credit-col
- debit-col bal-col))))
(define nrows (if link-rows (length link-rows) 1))
(define (link-data->cols link-data)
(cond
@@ -321,9 +338,7 @@
"number-cell" (link-data-amount link-data)))))
((link-desc-amount? link-data)
- (let ((cols (count identity
- (map (lambda (f) (f column-vector))
- (list date-col ref-col type-col desc-col)))))
+ (let ((cols (num-cols column-vector 'rhs-span)))
(append
(addif (< 0 cols) (gnc:make-html-table-cell/size
1 cols (link-desc-amount-desc link-data)))
@@ -332,10 +347,7 @@
"number-cell" (link-desc-amount-amount link-data))))))
((link-blank? link-data)
- (make-list (count identity
- (map (lambda (f) (f column-vector))
- (list date-col ref-col type-col desc-col bal-col)))
- #f))
+ (make-list (num-cols column-vector 'rhs-cols) #f))
(else link-data)))
(define (cell amt)
@@ -351,6 +363,8 @@
(gnc:html-table-cell-set-style!
cell "td" 'attribute '("style" "border-bottom: none; border-top: none;"))
cell))
+ (define mid-span
+ (if (eq? link-option 'detailed) (num-cols column-vector 'mid-spac) 0))
(let lp ((link-rows link-rows)
(first-row? #t))
(unless (null? link-rows)
@@ -377,7 +391,7 @@
(addif (credit-col column-vector) (cell-anchor credit))
(addif (debit-col column-vector) (cell-anchor (and debit (- debit))))
(addif (bal-col column-vector) (cell amt))))
- (addif (eq? link-option 'detailed) cell-nohoriz)
+ (addif (< 0 mid-span) cell-nohoriz)
(link-data->cols (car link-rows))))
(gnc:html-table-append-row/markup!
table (if odd-row? "normal-row" "alternate-row")
@@ -389,63 +403,68 @@
(define (AP-negate num)
(if payable? (- num) num))
(define currency (xaccAccountGetCommodity acc))
- (define link-cols (assq-ref `((none . 0)
- (simple . 1)
- (detailed . ,(num-link-cols used-columns)))
- link-option))
+ (define rhs-cols (assq-ref `((none . 0)
+ (simple . 1)
+ (detailed . ,(num-cols used-columns 'rhs-cols)))
+ link-option))
+ (define mid-span
+ (if (eq? link-option 'detailed) (num-cols used-columns 'mid-spac) 0))
(define (print-totals total debit credit tax sale)
(define (total-cell cell)
(gnc:make-html-table-cell/markup "total-number-cell" cell))
(define (make-cell amt)
(total-cell (gnc:make-gnc-monetary currency amt)))
- (define span
- (count identity (map (lambda (f) (f used-columns))
- (list desc-col type-col ref-col date-due-col date-col))))
+ (define period-span (num-cols used-columns 'ptt-span))
+ (define grand-span (num-cols used-columns 'lhs-cols))
;; print period totals
(if (or (sale-col used-columns) (tax-col used-columns)
(credit-col used-columns) (debit-col used-columns))
(gnc:html-table-append-row/markup!
table "grand-total"
(append
- (list (gnc:make-html-table-cell/markup
- "total-label-cell" (_ "Period Totals")))
- (addif (>= span 2) (gnc:make-html-table-cell/size 1 (1- span) ""))
+ (addif (< 0 period-span) (gnc:make-html-table-cell/markup
+ "total-label-cell" (_ "Period Totals")))
+ (addif (< 1 period-span) (gnc:make-html-table-cell/size
+ 1 (1- period-span) #f))
(addif (sale-col used-columns) (make-cell sale))
(addif (tax-col used-columns) (make-cell tax))
(addif (credit-col used-columns) (make-cell credit))
(addif (debit-col used-columns) (make-cell (- debit)))
(addif (bal-col used-columns) (make-cell (+ credit debit)))
- (addif (> link-cols 0) (gnc:make-html-table-cell/size 1 link-cols #f)))))
+ (addif (< 0 rhs-cols) (gnc:make-html-table-cell/size
+ 1 (+ mid-span rhs-cols) #f)))))
;; print grand total
(if (bal-col used-columns)
(gnc:html-table-append-row/markup!
table "grand-total"
(append
- (list (gnc:make-html-table-cell/markup
- "total-label-cell"
- (if (negative? total)
- (_ "Total Credit")
- (_ "Total Due")))
- (gnc:make-html-table-cell/size/markup
- 1 (bal-col used-columns)
- "total-number-cell"
- (gnc:make-gnc-monetary currency total)))
- (addif (> link-cols 0)
- (gnc:make-html-table-cell/size 1 link-cols #f)))))
+ (addif (< 1 grand-span)
+ (gnc:make-html-table-cell/markup
+ "total-label-cell"
+ (if (negative? total)
+ (_ "Total Credit")
+ (_ "Total Due"))))
+ (addif (< 1 grand-span)
+ (gnc:make-html-table-cell/size/markup
+ 1 (1- grand-span)
+ "total-number-cell"
+ (gnc:make-gnc-monetary currency total)))
+ (addif (< 0 rhs-cols)
+ (gnc:make-html-table-cell/size 1 (+ mid-span rhs-cols) #f)))))
;; print aging table
(gnc:html-table-append-row/markup!
table "grand-total"
(list (gnc:make-html-table-cell/size
- 1 (+ columns-used-size link-cols)
+ 1 (+ grand-span mid-span rhs-cols)
(make-aging-table splits
end-date
payable? date-type currency)))))
(define (add-balance-row odd-row? total)
(add-row table odd-row? used-columns start-date #f "" (_ "Balance") ""
- currency total #f #f #f #f (list (make-list link-cols #f))
+ currency total #f #f #f #f (list (make-list rhs-cols #f))
link-option (case link-option
((none) '(()))
((simple) '((#f)))
@@ -914,6 +933,7 @@ invoices and amounts.")))))
(query (qof-query-create-for-splits))
(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))
(report-title (string-append (_ owner-descr) " " (_ "Report"))))
@@ -1022,7 +1042,11 @@ invoices and amounts.")))))
(make-break! document)
- (gnc:html-table-set-col-headers! table headings)
+ (gnc:html-table-set-multirow-col-headers!
+ table
+ (if (eq? link-option 'detailed)
+ (list section-headings headings)
+ (list headings)))
(gnc:html-document-add-object! document table))))))
commit 0397aca1448fdd320e45bc02fb0b504d5ac26a29
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Dec 27 21:11:03 2019 +0700
[html-table][API] html-table can have multirow-col-headers
NEW API:
gnc:html-table-multirow-col-headers and
gnc:html-table-set-multirow-col-headers!
gnc:html-table col-headers have been augmented to support list of th
rows.
* BACKWARD COMPATIBILITY is offered. old use of single-row headers API
gnc:html-table-col-headers and gnc:html-table-set-col-headers! should
be unchanged; will get/set a single row of th elements.
* NEW functions gnc:html-table-multirow-col-headers and
gnc:html-table-set-multirow-col-headers! will get/set an arbitrary
number of rows of th elements.
* using old API gnc:html-table-col-headers on a table, whose multiple
row headers have been set, will lead to a warning and return the first
row only.
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 771b2dab3..77adda8eb 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -204,17 +204,33 @@
(define gnc:html-table-set-caption!
(record-modifier <html-table> 'caption))
-(define gnc:html-table-col-headers
+;; note the following function is now generally unused.
+(define (gnc:html-table-col-headers table)
+ (issue-deprecation-warning "gnc:html-table-col-headers is deprecated. \
+use gnc:html-table-multirow-col-headers instead.")
+ (let ((headers ((record-accessor <html-table> 'col-headers) table)))
+ (cond
+ ((not headers) #f)
+ ((null? (cdr headers)) (car headers))
+ (else (gnc:warn "gnc:html-table-col-headers used on a table object \
+with multiple rows. returning the first row only.") (car headers)))))
+
+(define (gnc:html-table-set-col-headers! table col-headers)
+ (gnc:html-table-set-multirow-col-headers! table (list col-headers)))
+
+(define gnc:html-table-multirow-col-headers
(record-accessor <html-table> 'col-headers))
-(define gnc:html-table-set-col-headers!
+(define gnc:html-table-set-multirow-col-headers!
(record-modifier <html-table> 'col-headers))
-(define gnc:html-table-row-headers
- (record-accessor <html-table> 'row-headers))
+(define (gnc:html-table-row-headers table)
+ (issue-deprecation-warning "gnc:html-table-row-headers is unused.")
+ ((record-accessor <html-table> 'row-headers) table))
-(define gnc:html-table-set-row-headers!
- (record-modifier <html-table> 'row-headers))
+(define (gnc:html-table-set-row-headers! table . rest)
+ (issue-deprecation-warning "gnc:html-table-set-row-headers! is unused.")
+ (apply (record-modifier <html-table> 'row-headers) table rest))
(define gnc:html-table-style
(record-accessor <html-table> 'style))
@@ -458,7 +474,7 @@
;; compile the col styles with the header style pushed; we'll
;; recompile them later, but this will have the benefit of
;; compiling in the col-header-style.
- (let ((ch (gnc:html-table-col-headers table)))
+ (let ((ch (gnc:html-table-multirow-col-headers table)))
(when ch
(gnc:html-document-push-style doc (gnc:html-table-col-headers-style table))
@@ -473,25 +489,29 @@
;; render the headers
(push (gnc:html-document-markup-start doc "thead" #t))
- (push (gnc:html-document-markup-start doc "tr" #t))
- (let lp ((ch ch)
- (colnum 0))
- (unless (null? ch)
- (let ((hdr (car ch)))
- (gnc:html-document-push-style
- doc (gnc:html-table-col-style table colnum))
- (unless (gnc:html-table-cell? hdr)
- (push (gnc:html-document-markup-start doc "th" #t)))
- (push (gnc:html-object-render hdr doc))
- (unless (gnc:html-table-cell? hdr)
- (push (gnc:html-document-markup-end doc "th")))
- (gnc:html-document-pop-style doc)
- (lp (cdr ch)
- (+ colnum
- (if (gnc:html-table-cell? hdr)
- (gnc:html-table-cell-colspan hdr)
- 1))))))
- (push (gnc:html-document-markup-end doc "tr"))
+
+ (for-each
+ (lambda (ch-row)
+ (push (gnc:html-document-markup-start doc "tr" #t))
+ (let lp ((ch-row ch-row) (colnum 0))
+ (unless (null? ch-row)
+ (let* ((hdr (car ch-row))
+ (table-cell? (gnc:html-table-cell? hdr))
+ (col-style (gnc:html-table-col-style table colnum)))
+ (gnc:html-document-push-style doc col-style)
+ (cond
+ (table-cell?
+ (push (gnc:html-object-render hdr doc)))
+ (else
+ (push (gnc:html-document-markup-start doc "th" #t))
+ (push (gnc:html-object-render hdr doc))
+ (push (gnc:html-document-markup-end doc "th"))))
+ (gnc:html-document-pop-style doc)
+ (lp (cdr ch-row)
+ (+ colnum
+ (if table-cell? (gnc:html-table-cell-colspan hdr) 1))))))
+ (push (gnc:html-document-markup-end doc "tr")))
+ ch)
(push (gnc:html-document-markup-end doc "thead"))
;; pop the col header style
diff --git a/gnucash/report/report-system/report-system.scm b/gnucash/report/report-system/report-system.scm
index cd0e32526..1153e62b0 100644
--- a/gnucash/report/report-system/report-system.scm
+++ b/gnucash/report/report-system/report-system.scm
@@ -586,6 +586,8 @@
(export gnc:html-table-set-caption!)
(export gnc:html-table-col-headers)
(export gnc:html-table-set-col-headers!)
+(export gnc:html-table-multirow-col-headers)
+(export gnc:html-table-set-multirow-col-headers!)
(export gnc:html-table-row-headers)
(export gnc:html-table-set-row-headers!)
(export gnc:html-table-style)
commit f3499686baf8d5df4d455df280728a8988722f0a
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Dec 28 21:56:17 2019 +0700
[new-owner-report] style monetary sale/tax cols with number-cell
diff --git a/gnucash/report/business-reports/new-owner-report.scm b/gnucash/report/business-reports/new-owner-report.scm
index b2c43f8fc..b83854ed4 100644
--- a/gnucash/report/business-reports/new-owner-report.scm
+++ b/gnucash/report/business-reports/new-owner-report.scm
@@ -367,13 +367,13 @@
(and due-date (qof-print-date due-date)))
(addif (ref-col column-vector) ref)
(addif (type-col column-vector) type-str)
- (addif (desc-col column-vector) desc)
- (addif (sale-col column-vector) (cell sale))
- (addif (tax-col column-vector) (cell tax))))
+ (addif (desc-col column-vector) desc)))
(map
(lambda (cell)
(gnc:make-html-table-cell/size/markup nrows 1 "number-cell" cell))
(append
+ (addif (sale-col column-vector) (cell sale))
+ (addif (tax-col column-vector) (cell tax))
(addif (credit-col column-vector) (cell-anchor credit))
(addif (debit-col column-vector) (cell-anchor (and debit (- debit))))
(addif (bal-col column-vector) (cell amt))))
Summary of changes:
.../report/business-reports/new-owner-report.scm | 136 ++++++++++++---------
gnucash/report/report-system/html-table.scm | 72 +++++++----
gnucash/report/report-system/report-system.scm | 2 +
3 files changed, 128 insertions(+), 82 deletions(-)
More information about the gnucash-changes
mailing list