gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Wed Oct 9 09:15:39 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/662d29d6 (commit)
via https://github.com/Gnucash/gnucash/commit/ef3bc616 (commit)
via https://github.com/Gnucash/gnucash/commit/8a46daeb (commit)
via https://github.com/Gnucash/gnucash/commit/6370b0f7 (commit)
via https://github.com/Gnucash/gnucash/commit/ca5f5871 (commit)
via https://github.com/Gnucash/gnucash/commit/1abda45c (commit)
via https://github.com/Gnucash/gnucash/commit/d45f0621 (commit)
via https://github.com/Gnucash/gnucash/commit/49e65130 (commit)
via https://github.com/Gnucash/gnucash/commit/3a2c85f5 (commit)
from https://github.com/Gnucash/gnucash/commit/f4794d51 (commit)
commit 662d29d664d6834b66caf7c9a24a9543d8571d13
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:42:26 2019 +0800
[average-balance] show monetaries instead of numbers in data table
instead of numbers, show monetary amounts, rounded to SCU
diff --git a/gnucash/report/standard-reports/average-balance.scm b/gnucash/report/standard-reports/average-balance.scm
index 07d239065..8da8063ed 100644
--- a/gnucash/report/standard-reports/average-balance.scm
+++ b/gnucash/report/standard-reports/average-balance.scm
@@ -486,7 +486,8 @@
;; make a table (optionally)
(gnc:report-percent-done 80)
(if show-table?
- (let ((table (gnc:make-html-table)))
+ (let ((table (gnc:make-html-table))
+ (scu (gnc-commodity-get-fraction report-currency)))
(gnc:html-table-set-col-headers!
table columns)
(for-each
@@ -498,7 +499,14 @@
(list "date-cell" "date-cell"
"number-cell" "number-cell" "number-cell"
"number-cell" "number-cell" "number-cell")
- row)))
+ (cons* (car row)
+ (cadr row)
+ (map
+ (lambda (amt)
+ (gnc:make-gnc-monetary
+ report-currency
+ (gnc-numeric-convert amt scu GNC-RND-ROUND)))
+ (cddr row))))))
data)
(gnc:html-document-add-object! document table))))
diff --git a/gnucash/report/standard-reports/test/test-average-balance.scm b/gnucash/report/standard-reports/test/test-average-balance.scm
index c40ca3d22..0f96a01fa 100644
--- a/gnucash/report/standard-reports/test/test-average-balance.scm
+++ b/gnucash/report/standard-reports/test/test-average-balance.scm
@@ -67,35 +67,35 @@
(let* ((options (default-testing-options))
(sxml (options->sxml options "default")))
(test-equal "averages"
- '("0.00" "50.00" "100.00" "150.00" "200.00" "200.00")
+ '("$0.00" "$50.00" "$100.00" "$150.00" "$200.00" "$200.00")
(get-row-col sxml #f 3))
(test-equal "maximums"
- '("0.00" "100.00" "100.00" "200.00" "200.00" "200.00")
+ '("$0.00" "$100.00" "$100.00" "$200.00" "$200.00" "$200.00")
(get-row-col sxml #f 4))
(test-equal "minimums"
- '("0.00" "0.00" "100.00" "100.00" "200.00" "200.00")
+ '("$0.00" "$0.00" "$100.00" "$100.00" "$200.00" "$200.00")
(get-row-col sxml #f 5))
(test-equal "net"
- '("0.00" "100.00" "0.00" "100.00" "0.00" "0.00")
+ '("$0.00" "$100.00" "$0.00" "$100.00" "$0.00" "$0.00")
(get-row-col sxml #f 8)))
(env-transfer env 15 03 1979 bank bank2 25)
(let* ((options (default-testing-options))
(sxml (options->sxml options "include-internal")))
(test-equal "gains-include-internal"
- '("0.00" "100.00" "25.00" "100.00" "0.00" "0.00")
+ '("$0.00" "$100.00" "$25.00" "$100.00" "$0.00" "$0.00")
(get-row-col sxml #f 6))
(test-equal "loss-include-internal"
- '("0.00" "0.00" "25.00" "0.00" "0.00" "0.00")
+ '("$0.00" "$0.00" "$25.00" "$0.00" "$0.00" "$0.00")
(get-row-col sxml #f 7)))
(let* ((options (default-testing-options)))
(set-option! options "Accounts" "Exclude transactions between selected accounts" #t)
(let ((sxml (options->sxml options "exclude-internal")))
(test-equal "gain-exclude-internal"
- '("0.00" "100.00" "0.00" "100.00" "0.00" "0.00")
+ '("$0.00" "$100.00" "$0.00" "$100.00" "$0.00" "$0.00")
(get-row-col sxml #f 6))
(test-equal "loss-exclude-internal"
- '("0.00" "0.00" "0.00" "0.00" "0.00" "0.00")
+ '("$0.00" "$0.00" "$0.00" "$0.00" "$0.00" "$0.00")
(get-row-col sxml #f 7))))
(teardown)))
commit ef3bc616b2dafbd2ef9886b12e603e9e37bee565
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Oct 8 22:01:45 2019 +0800
[html-table] refactor and dedupe row/col modifiers
* dedupe gnc:html-table-set-cell/tag!
* dedupe gnc:html-table-set-cell!
* create internal fn gnc:html-table-set-cell-datum! for above fns
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index eb4cea990..755fa0151 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -376,80 +376,34 @@
(len (length dd)))
(list-ref-safe dd (- len row 1))))
-;; if the 4th arg is a cell, overwrite the existing cell,
-;; otherwise, append all remaining objects to the existing cell
+;; this function is not exported
+(define (gnc:html-table-set-cell-datum! table row col datum)
+ (let lp ((len (length (gnc:html-table-data table))))
+ (cond
+ ((< row len)
+ (let* ((row-loc (- len row 1))
+ (old-tbldata (gnc:html-table-data table))
+ (old-rowdata (list-ref old-tbldata row-loc))
+ (new-rowdata (list-set-safe! old-rowdata col datum))
+ (new-tbldata (list-set-safe! old-tbldata row-loc new-rowdata)))
+ ;; add the row-data back to the table
+ (gnc:html-table-set-data! table new-tbldata)))
+ (else
+ (gnc:html-table-append-row! table '())
+ (lp (1+ len))))))
+
(define (gnc:html-table-set-cell! table row col . objects)
- (let ((rowdata #f)
- (row-loc #f)
- (l (length (gnc:html-table-data table)))
- (objs (length objects))
- )
- ;; ensure the row-data is there
- (if (>= row l)
- (begin
- (let loop ((i l))
- (gnc:html-table-append-row! table (list))
- (if (< i row)
- (loop (+ i 1))))
- (set! l (gnc:html-table-num-rows table))
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list)))
- (begin
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list-ref (gnc:html-table-data table) row-loc))))
-
- ;; make a table-cell and set the data
- (let* ((tc (gnc:make-html-table-cell))
- (first (car objects)))
- (if (and (equal? objs 1) (gnc:html-table-cell? first))
- (set! tc first)
- (apply gnc:html-table-cell-append-objects! tc objects)
- )
- (set! rowdata (list-set-safe! rowdata col tc))
-
- ;; add the row-data back to the table
- (gnc:html-table-set-data!
- table (list-set-safe!
- (gnc:html-table-data table)
- row-loc rowdata)))))
-
-;; if the 4th arg is a cell, overwrite the existing cell,
-;; otherwise, append all remaining objects to the existing cell
+ (let ((tc (if (and (= (length objects) 1) (gnc:html-table-cell? (car objects)))
+ (car objects)
+ (apply gnc:make-html-table-cell objects))))
+ (gnc:html-table-set-cell-datum! table row col tc)))
+
(define (gnc:html-table-set-cell/tag! table row col tag . objects)
- (let ((rowdata #f)
- (row-loc #f)
- (l (length (gnc:html-table-data table)))
- (num-objs (length objects))
- )
- ;; ensure the row-data is there
- (if (>= row l)
- (begin
- (let loop ((i l))
- (gnc:html-table-append-row! table (list))
- (if (< i row)
- (loop (+ i 1))))
- (set! l (gnc:html-table-num-rows table))
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list)))
- (begin
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list-ref (gnc:html-table-data table) row-loc))))
-
- ;; make a table-cell and set the data
- (let* ((tc (gnc:make-html-table-cell))
- (first (car objects)))
- (if (and (equal? num-objs 1) (gnc:html-table-cell? first))
- (set! tc first)
- (apply gnc:html-table-cell-append-objects! tc objects)
- )
- (gnc:html-table-cell-set-tag! tc tag)
- (set! rowdata (list-set-safe! rowdata col tc))
-
- ;; add the row-data back to the table
- (gnc:html-table-set-data!
- table (list-set-safe!
- (gnc:html-table-data table)
- row-loc rowdata)))))
+ (let ((tc (if (and (= (length objects) 1) (gnc:html-table-cell? (car objects)))
+ (car objects)
+ (apply gnc:make-html-table-cell objects))))
+ (gnc:html-table-cell-set-tag! tc tag)
+ (gnc:html-table-set-cell-datum! table row col tc)))
(define (gnc:html-table-append-column! table newcol)
commit 8a46daeb8c67ed4a6900d15dc8c916665f698d61
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 05:49:53 2019 +0800
[html-table] convert to srfi-2 and-let*
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 69f3b7b3f..eb4cea990 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -23,6 +23,8 @@
;; Boston, MA 02110-1301, USA gnu at gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(use-modules (srfi srfi-2))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; NB: In this code, "markup" and "/markup" *do not* refer to
@@ -365,22 +367,14 @@
(gnc:html-table-set-row-markup-table! table new-rowmarkup))
new-num-rows))
-;; list-set! is 0-based...
-;; (let ((a '(0 1 2))) (list-set! a 1 "x") a)
-;; => (0 "x" 2)
(define (gnc:html-table-get-cell table row col)
- (let* ((row (gnc:html-table-get-row table row)))
- (and row (list-ref-safe row col)))
- )
+ (and-let* ((row (gnc:html-table-get-row table row)))
+ (list-ref-safe row col)))
(define (gnc:html-table-get-row table row)
- (let* ((dd (gnc:html-table-data table))
- (len (and dd (length dd)))
- )
- (and len
- (list-ref-safe dd (- (- len 1) row))
- )
- ))
+ (and-let* ((dd (gnc:html-table-data table))
+ (len (length dd)))
+ (list-ref-safe dd (- len row 1))))
;; if the 4th arg is a cell, overwrite the existing cell,
;; otherwise, append all remaining objects to the existing cell
commit 6370b0f7ee4399fe223a269e95bf4283a9f7d773
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:27:18 2019 +0800
[html-table] html-table-cell negative amount does not apply to <td>
Only number-cell and total-number-cell have negative-amount styles.
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index c2a28efc6..69f3b7b3f 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -146,6 +146,7 @@
(cell-tag (gnc:html-table-cell-tag cell))
(cell-data (gnc:html-table-cell-data cell))
(tag (if (and (= 1 (length cell-data))
+ (not (string=? cell-tag "td"))
(or (and (gnc:gnc-monetary? (car cell-data))
(negative? (gnc:gnc-monetary-amount (car cell-data))))
(and (number? (car cell-data))
diff --git a/gnucash/report/report-system/test/test-report-html.scm b/gnucash/report/report-system/test/test-report-html.scm
index 6c5a3e637..5c672690c 100644
--- a/gnucash/report/report-system/test/test-report-html.scm
+++ b/gnucash/report/report-system/test/test-report-html.scm
@@ -849,9 +849,10 @@ HTML Document Title</title></head><body></body>\n\
(let* ((doc (gnc:make-html-document))
(comm-table (gnc-commodity-table-get-table (gnc-get-current-book)))
(USD (gnc-commodity-table-lookup comm-table "CURRENCY" "USD"))
- (cell (gnc:make-html-table-cell (gnc:make-gnc-monetary USD -10))))
+ (USD-neg10 (gnc:make-gnc-monetary USD -10))
+ (cell (gnc:make-html-table-cell/markup "number-cell" USD-neg10)))
(test-equal "html-table-cell negative-monetary -> tag gets -neg appended"
- "td-neg"
+ "number-cell-neg"
(cadr
(gnc:html-document-tree-collapse
(gnc:html-table-cell-render cell doc)))))
commit ca5f587156ed28aa40f76d81aefc325c89be1974
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:14:08 2019 +0800
[html-table] compact gnc:html-table-render
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 6703da501..c2a28efc6 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -529,144 +529,120 @@
remaining-elements)
#f))))
-;;
-;; It would be nice to have table row/col/cell accessor functions in here.
-;; It would also be nice to have table juxtaposition functions, too.
-;; i.e., (gnc:html-table-nth-row table n)
-;; [ CAS: how is that different from gnc:html-table-get-row ? ]
-
-;; (gnc:html-table-append-table-horizontal table add-table)
-;; (An old merge-table used to exist inside balance-sheet.scm/GnuCash 1.8.9.)
-;; Feel free to contribute! :-)
-;;
-
(define (gnc:html-table-render table doc)
(let* ((retval '())
(push (lambda (l) (set! retval (cons l retval)))))
-
- ;; compile the table style to make other compiles faster
- (gnc:html-style-table-compile
- (gnc:html-table-style table) (gnc:html-document-style-stack doc))
-
+
+ ;; compile the table style to make other compiles faster
+ (gnc:html-style-table-compile (gnc:html-table-style table)
+ (gnc:html-document-style-stack doc))
+
(gnc:html-document-push-style doc (gnc:html-table-style table))
(push (gnc:html-document-markup-start doc "table" #t))
-
- ;; render the caption
+
+ ;; render the caption
(let ((c (gnc:html-table-caption table)))
- (if c
- (begin
- (push (gnc:html-document-markup-start doc "caption" #t))
- (push (gnc:html-object-render c doc))
- (push (gnc:html-document-markup-end doc "caption")))))
-
+ (when c
+ (push (gnc:html-document-markup-start doc "caption" #t))
+ (push (gnc:html-object-render c doc))
+ (push (gnc:html-document-markup-end doc "caption"))))
+
;; the first row is the column headers. Columns styles apply.
;; 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))
- (colnum 0))
- (if ch
- (begin
- (gnc:html-document-push-style
- doc (gnc:html-table-col-headers-style table))
-
- ;; compile the column styles just in case there's
- ;; something interesting in the table header cells.
- (hash-fold
- (lambda (col style init)
- (if style
- (gnc:html-style-table-compile
- style (gnc:html-document-style-stack doc)))
- #f)
- #f (gnc:html-table-col-styles table))
-
- ;; render the headers
- (push (gnc:html-document-markup-start doc "thead" #t))
- (push (gnc:html-document-markup-start doc "tr" #t))
- (for-each
- (lambda (hdr)
- (gnc:html-document-push-style
- doc (gnc:html-table-col-style table colnum))
- (if (not (gnc:html-table-cell? hdr))
- (push (gnc:html-document-markup-start doc "th" #t)))
- (push (gnc:html-object-render hdr doc))
- (if (not (gnc:html-table-cell? hdr))
- (push (gnc:html-document-markup-end doc "th")))
- (gnc:html-document-pop-style doc)
- (if (not (gnc:html-table-cell? hdr))
- (set! colnum (+ 1 colnum))
- (set! colnum (+ (gnc:html-table-cell-colspan hdr)
- colnum))))
- ch)
- (push (gnc:html-document-markup-end doc "tr"))
- (push (gnc:html-document-markup-end doc "thead"))
-
- ;; pop the col header style
- (gnc:html-document-pop-style doc))))
-
+ (let ((ch (gnc:html-table-col-headers table)))
+ (when ch
+ (gnc:html-document-push-style doc (gnc:html-table-col-headers-style table))
+
+ ;; compile the column styles just in case there's something
+ ;; interesting in the table header cells.
+ (hash-for-each
+ (lambda (col style)
+ (when style
+ (gnc:html-style-table-compile
+ style (gnc:html-document-style-stack doc))))
+ (gnc:html-table-col-styles table))
+
+ ;; 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"))
+ (push (gnc:html-document-markup-end doc "thead"))
+
+ ;; pop the col header style
+ (gnc:html-document-pop-style doc)))
+
;; recompile the column styles. We won't worry about the row
;; styles; if they're there, we may lose, but not much, and they
;; will be pretty rare (I think).
- (hash-fold
- (lambda (col style init)
- (if style
- (gnc:html-style-table-compile
- style (gnc:html-document-style-stack doc)))
- #f)
- #f (gnc:html-table-col-styles table))
-
+ (hash-for-each
+ (lambda (col style)
+ (when style
+ (gnc:html-style-table-compile style (gnc:html-document-style-stack doc))))
+ (gnc:html-table-col-styles table))
+
(push (gnc:html-document-markup-start doc "tbody" #t))
- ;; now iterate over the rows
- (let ((rownum 0) (colnum 0))
- (for-each
- (lambda (row)
- (let ((rowstyle
- (gnc:html-table-row-style table rownum))
- (rowmarkup
- (gnc:html-table-row-markup table rownum)))
- ;; set default row markup
- (if (not rowmarkup)
- (set! rowmarkup "tr"))
-
- ;; push the style for this row and write the start tag, then
- ;; pop it again.
- (if rowstyle (gnc:html-document-push-style doc rowstyle))
- (push (gnc:html-document-markup-start doc rowmarkup #t))
- (if rowstyle (gnc:html-document-pop-style doc))
-
- ;; write the column data, pushing the right column style
- ;; each time, then the row style.
- (for-each
- (lambda (datum)
- (let ((colstyle
- (gnc:html-table-col-style table colnum)))
- ;; push col and row styles
- (if colstyle (gnc:html-document-push-style doc colstyle))
- (if rowstyle (gnc:html-document-push-style doc rowstyle))
-
- ;; render the cell contents
- (if (not (gnc:html-table-cell? datum))
- (push (gnc:html-document-markup-start doc "td" #t)))
+ ;; now iterate over the rows
+ (let rowloop ((rows (reverse (gnc:html-table-data table))) (rownum 0))
+ (unless (null? rows)
+ (let* ((row (car rows))
+ (rowstyle (gnc:html-table-row-style table rownum))
+ (rowmarkup (or (gnc:html-table-row-markup table rownum) "tr")))
+
+ ;; push the style for this row and write the start tag, then
+ ;; pop it again.
+ (when rowstyle (gnc:html-document-push-style doc rowstyle))
+ (push (gnc:html-document-markup-start doc rowmarkup #t))
+ (when rowstyle (gnc:html-document-pop-style doc))
+
+ ;; write the column data, pushing the right column style
+ ;; each time, then the row style.
+ (let colloop ((cols row) (colnum 0))
+ (unless (null? cols)
+ (let* ((datum (car cols))
+ (colstyle (gnc:html-table-col-style table colnum)))
+ ;; push col and row styles
+ (when colstyle (gnc:html-document-push-style doc colstyle))
+ (when rowstyle (gnc:html-document-push-style doc rowstyle))
+
+ ;; render the cell contents
+ (unless (gnc:html-table-cell? datum)
+ (push (gnc:html-document-markup-start doc "td" #t)))
(push (gnc:html-object-render datum doc))
- (if (not (gnc:html-table-cell? datum))
- (push (gnc:html-document-markup-end doc "td")))
-
- ;; pop styles
- (if rowstyle (gnc:html-document-pop-style doc))
- (if colstyle (gnc:html-document-pop-style doc))
- (set! colnum (+ 1 colnum))))
- row)
-
- ;; write the row end tag and pop the row style
- (if rowstyle (gnc:html-document-push-style doc rowstyle))
- (push (gnc:html-document-markup-end doc rowmarkup))
- (if rowstyle (gnc:html-document-pop-style doc))
-
- (set! colnum 0)
- (set! rownum (+ 1 rownum))))
- (reverse (gnc:html-table-data table))))
+ (unless (gnc:html-table-cell? datum)
+ (push (gnc:html-document-markup-end doc "td")))
+
+ ;; pop styles
+ (when rowstyle (gnc:html-document-pop-style doc))
+ (when colstyle (gnc:html-document-pop-style doc))
+ (colloop (cdr cols) (1+ colnum)))))
+
+ ;; write the row end tag and pop the row style
+ (when rowstyle (gnc:html-document-push-style doc rowstyle))
+ (push (gnc:html-document-markup-end doc rowmarkup))
+ (when rowstyle (gnc:html-document-pop-style doc))
+
+ (rowloop (cdr rows) (1+ rownum)))))
(push (gnc:html-document-markup-end doc "tbody"))
-
+
;; write the table end tag and pop the table style
(push (gnc:html-document-markup-end doc "table"))
(gnc:html-document-pop-style doc)
commit 1abda45cf62d4fea18aefa1877749f78b673e9f9
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:13:17 2019 +0800
[html-table] compact gnc:html-table-append-column!
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index d7f20c5a6..6703da501 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -457,72 +457,36 @@
row-loc rowdata)))))
(define (gnc:html-table-append-column! table newcol)
- (define (maxwidth table-data)
- (if (null? table-data) 0
- (max (length (car table-data)) (maxwidth (cdr table-data)))))
-
- ;; widen an individual row to the required width and append element
- (define (widen-and-append row element width)
- (let ((current-width (length row))
- (new-suffix (list element)))
- (do
- ((i current-width (+ i 1)))
- ((>= 1 (- width i)))
- (set! new-suffix (cons #f new-suffix)))
- (append row new-suffix)))
-
- ;; append the elements of newcol to each of the existing rows, widening
- ;; to width-to-make if necessary
- (define (append-to-element newcol existing-data length-to-append
- width-to-make)
- (if (= length-to-append 0)
+
+ ;; append the elements of newcol to each of the existing rows,
+ ;; widening to width-to-make if necessary
+ (define (append-to-element newcol existing-data length-to-append colnum)
+ (if (= length-to-append 0)
(cons '() newcol)
- (let*
- ((current-new (car newcol))
- (current-existing (car existing-data))
- (rest-new (cdr newcol))
- (rest-existing (cdr existing-data))
- (rest-result (append-to-element rest-new rest-existing
- (- length-to-append 1)
- width-to-make)))
- (cons (cons (widen-and-append
- current-existing
- current-new
- width-to-make )
- (car rest-result))
- (cdr rest-result)))))
-
- (let* ((existing-data (reverse (gnc:html-table-data table)))
- (existing-length (length existing-data))
- (width-to-make (+ (maxwidth existing-data) 1))
- (newcol-length (length newcol)))
- (if (<= newcol-length existing-length)
- (gnc:html-table-set-data!
+ (let ((result (append-to-element
+ (cdr newcol) (cdr existing-data) (1- length-to-append)
+ colnum)))
+ (cons (cons (list-set-safe! (car existing-data) colnum (car newcol))
+ (car result))
+ (cdr result)))))
+
+ (let* ((old-data (reverse (gnc:html-table-data table)))
+ (old-numrows (length old-data))
+ (old-numcols (apply max (cons 0 (map length old-data))))
+ (new-numrows (length newcol)))
+ (if (<= new-numrows old-numrows)
+ (gnc:html-table-set-data!
table
- (reverse (car (append-to-element
- newcol
- existing-data
- newcol-length
- width-to-make))))
- (let* ((temp-result (append-to-element
- newcol
- existing-data
- existing-length
- width-to-make))
- (joined-table-data (car temp-result))
- (remaining-elements (cdr temp-result)))
+ (reverse (car (append-to-element newcol old-data new-numrows old-numcols))))
+ (let ((res (append-to-element newcol old-data old-numrows old-numcols)))
;; Invariant maintained - table data in reverse order
- (gnc:html-table-set-data! table (reverse joined-table-data))
-
- (for-each
+ (gnc:html-table-set-data! table (reverse (car res)))
+
+ (for-each
(lambda (element)
- (gnc:html-table-append-row! table
- (widen-and-append
- '()
- element
- width-to-make)))
- remaining-elements)
- #f))))
+ (gnc:html-table-append-row!
+ table (list-set-safe! '() old-numcols element)))
+ (cdr res))))))
(define (gnc:html-table-prepend-column! table newcol)
;; returns a pair, the car of which is the prepending of newcol
commit d45f06215f1f1d10cb360148f74f0385d76cb62e
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:12:59 2019 +0800
[html-table] compact gnc:html-table-prepend-row!
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 9654225a7..d7f20c5a6 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -340,35 +340,28 @@
'()))
(define (gnc:html-table-prepend-row! table newrow)
- (let* ((dd (gnc:html-table-data table))
- (current-num-rows (gnc:html-table-num-rows table))
- (new-num-rows (+ current-num-rows 1))
- (newrow-list (if (list? newrow) newrow (list newrow))))
- (set! dd (append dd (list newrow-list)))
- (gnc:html-table-set-num-rows-internal!
- table
- new-num-rows)
+ (let* ((new-num-rows (1+ (gnc:html-table-num-rows table)))
+ (newrow-list (if (list? newrow) newrow (list newrow)))
+ (dd (append (gnc:html-table-data table) (list newrow-list))))
+ (gnc:html-table-set-num-rows-internal! table new-num-rows)
(gnc:html-table-set-data! table dd)
-
+
;; have to bump up the row index of the row styles and row markup
;; table on a prepend. just another reason you probably don't
;; want to prepend.
(let ((new-rowstyles (make-hash-table 21)))
- (hash-fold
- (lambda (row style prev)
- (hash-set! new-rowstyles (+ 1 row) style)
- #f)
- #f (gnc:html-table-row-styles table))
+ (hash-for-each
+ (lambda (row style)
+ (hash-set! new-rowstyles (+ 1 row) style))
+ (gnc:html-table-row-styles table))
(gnc:html-table-set-row-styles! table new-rowstyles))
(let ((new-rowmarkup (make-hash-table 21)))
- (hash-fold
- (lambda (row markup prev)
- (hash-set! new-rowmarkup (+ 1 row) markup)
- #f)
- #f (gnc:html-table-row-markup-table table))
+ (hash-for-each
+ (lambda (row markup)
+ (hash-set! new-rowmarkup (+ 1 row) markup))
+ (gnc:html-table-row-markup-table table))
(gnc:html-table-set-row-markup-table! table new-rowmarkup))
-
new-num-rows))
;; list-set! is 0-based...
commit 49e651304261b04e79401487e97cd8d124baedd3
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:12:28 2019 +0800
[html-table] compact functions, define vars in formals
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index edf96071d..9654225a7 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -125,14 +125,10 @@
(record-modifier <html-table-cell> 'style))
(define (gnc:html-table-cell-set-style! cell tag . rest)
- (let ((newstyle #f)
+ (let ((newstyle (if (and (= (length rest) 2) (procedure? (car rest)))
+ (apply gnc:make-html-data-style-info rest)
+ (apply gnc:make-html-markup-style-info rest)))
(styletable (gnc:html-table-cell-style cell)))
- (if (and (= (length rest) 2)
- (procedure? (car rest)))
- (set! newstyle
- (apply gnc:make-html-data-style-info rest))
- (set! newstyle
- (apply gnc:make-html-markup-style-info rest)))
(gnc:html-style-table-set! styletable tag newstyle)))
(define (gnc:html-table-cell-append-objects! cell . objects)
@@ -250,81 +246,50 @@
(record-accessor <html-table> 'col-headers-style))
(define (gnc:html-table-set-col-headers-style! table tag . rest)
- (let ((newstyle #f)
+ (let ((newstyle (if (and (= (length rest) 2) (procedure? (car rest)))
+ (apply gnc:make-html-data-style-info rest)
+ (apply gnc:make-html-markup-style-info rest)))
(style (gnc:html-table-col-headers-style table)))
- (if (and (= (length rest) 2)
- (procedure? (car rest)))
- (set! newstyle
- (apply gnc:make-html-data-style-info rest))
- (set! newstyle
- (apply gnc:make-html-markup-style-info rest)))
(gnc:html-style-table-set! style tag newstyle)))
(define gnc:html-table-row-headers-style
(record-accessor <html-table> 'row-headers-style))
(define (gnc:html-table-set-row-headers-style! table tag . rest)
- (let ((newstyle #f)
- (style (gnc:html-table-row-headers-style table)))
- (if (and (= (length rest) 2)
- (procedure? (car rest)))
- (set! newstyle
- (apply gnc:make-html-data-style-info rest))
- (set! newstyle
- (apply gnc:make-html-markup-style-info rest)))
+ (let* ((newstyle (if (and (= (length rest) 2) (procedure? (car rest)))
+ (apply gnc:make-html-data-style-info rest)
+ (apply gnc:make-html-markup-style-info rest)))
+ (style (gnc:html-table-row-headers-style table)))
(gnc:html-style-table-set! style tag newstyle)))
(define (gnc:html-table-set-style! table tag . rest)
- (let ((newstyle #f)
- (style (gnc:html-table-style table)))
- (if (and (= (length rest) 2)
- (procedure? (car rest)))
- (set! newstyle
- (apply gnc:make-html-data-style-info rest))
- (set! newstyle
- (apply gnc:make-html-markup-style-info rest)))
+ (let* ((newstyle (if (and (= (length rest) 2) (procedure? (car rest)))
+ (apply gnc:make-html-data-style-info rest)
+ (apply gnc:make-html-markup-style-info rest)))
+ (style (gnc:html-table-style table)))
(gnc:html-style-table-set! style tag newstyle)))
(define (gnc:html-table-set-col-style! table col tag . rest)
- (let ((newstyle #f)
- (style #f)
- (newhash #f))
- (if (and (= (length rest) 2)
- (procedure? (car rest)))
- (set! newstyle
- (apply gnc:make-html-data-style-info rest))
- (set! newstyle
- (apply gnc:make-html-markup-style-info rest)))
- (set! style
- (gnc:html-table-col-style table col))
- (if (not style)
- (begin
- (set! style (gnc:make-html-style-table))
- (set! newhash #t)))
+ (let* ((newstyle (if (and (= (length rest) 2) (procedure? (car rest)))
+ (apply gnc:make-html-data-style-info rest)
+ (apply gnc:make-html-markup-style-info rest)))
+ (newhash #f)
+ (style (or (gnc:html-table-col-style table col)
+ (begin (set! newhash #t)
+ (gnc:make-html-style-table)))))
(gnc:html-style-table-set! style tag newstyle)
- (if newhash
- (hash-set! (gnc:html-table-col-styles table) col style))))
+ (if newhash (hash-set! (gnc:html-table-col-styles table) col style))))
(define (gnc:html-table-set-row-style! table row tag . rest)
- (let ((newstyle #f)
- (style #f)
- (newhash #f))
- (if (and (= (length rest) 2)
- (procedure? (car rest)))
- (set! newstyle
- (apply gnc:make-html-data-style-info rest))
- (set! newstyle
- (apply gnc:make-html-markup-style-info rest)))
- (set! style
- (gnc:html-table-row-style table row))
- (if (not style)
- (begin
- (set! style (gnc:make-html-style-table))
- (set! newhash #t)))
+ (let* ((newstyle (if (and (= (length rest) 2) (procedure? (car rest)))
+ (apply gnc:make-html-data-style-info rest)
+ (apply gnc:make-html-markup-style-info rest)))
+ (newhash #f)
+ (style (or (gnc:html-table-row-style table row)
+ (begin (set! newhash #t)
+ (gnc:make-html-style-table)))))
(gnc:html-style-table-set! style tag newstyle)
- (if newhash
- (hash-set!
- (gnc:html-table-row-styles table) row style))))
+ (when newhash (hash-set! (gnc:html-table-row-styles table) row style))))
(define (gnc:html-table-row-style table row)
(hash-ref (gnc:html-table-row-styles table) row))
@@ -346,9 +311,8 @@
(gnc:html-table-set-row-markup! table (- rownum 1) markup)))
(define (gnc:html-table-prepend-row/markup! table markup newrow)
- (begin
- (gnc:html-table-prepend-row! table newrow)
- (gnc:html-table-set-row-markup! table 0 markup)))
+ (gnc:html-table-prepend-row! table newrow)
+ (gnc:html-table-set-row-markup! table 0 markup))
(define (gnc:html-table-append-row! table newrow)
commit 3a2c85f577ed580d39a51abbbf043fe7155001c6
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Oct 8 22:59:31 2019 +0800
[html-table] deprecate gnc:html-table-remove-last-row!
this function is unused in code.
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index a54206897..edf96071d 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -361,6 +361,7 @@
new-num-rows))
(define (gnc:html-table-remove-last-row! table)
+ (issue-deprecation-warning "gnc:html-table-remove-last-row! is unused.")
(if (> (gnc:html-table-num-rows table) 0)
(begin
(gnc:html-table-set-num-rows-internal!
Summary of changes:
gnucash/report/report-system/html-table.scm | 563 ++++++++-------------
.../report/report-system/test/test-report-html.scm | 5 +-
.../report/standard-reports/average-balance.scm | 12 +-
.../standard-reports/test/test-average-balance.scm | 16 +-
4 files changed, 226 insertions(+), 370 deletions(-)
More information about the gnucash-changes
mailing list