diff --git a/gnucash/report/report-system/html-document.scm b/gnucash/report/report-system/html-document.scm
index 3744eb79ad..ef050a1979 100644
--- a/gnucash/report/report-system/html-document.scm
+++ b/gnucash/report/report-system/html-document.scm
@@ -22,6 +22,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(gnc:module-load "gnucash/html" 0)
+(use-modules (ice-9 match))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; class
@@ -220,95 +221,74 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:html-document-markup-start doc markup end-tag? . rest)
- (let ((childinfo (gnc:html-document-fetch-markup-style doc markup))
- (extra-attrib (and (pair? rest) rest)))
- ;; now generate the start tag
- (let ((tag (gnc:html-markup-style-info-tag childinfo))
- (attr (gnc:html-markup-style-info-attributes childinfo))
- (face (gnc:html-markup-style-info-font-face childinfo))
- (size (gnc:html-markup-style-info-font-size childinfo))
- (color (gnc:html-markup-style-info-font-color childinfo)))
-
- ;; "" tags mean "show no tag"; #f tags means use default.
- (cond ((not tag)
- (set! tag markup))
- ((and (string? tag) (string=? tag ""))
- (set! tag #f)))
- (let* ((retval '())
- (push (lambda (l) (set! retval (cons l retval))))
- (add-internal-tag (lambda (tag) (push "<") (push tag) (push ">")))
- (add-attribute
- (lambda (key value prior)
- (push " ") (push key)
- (if value (begin (push "=\"")
- (push value)
- (push "\"")))
- #t))
- (addextraatt
- (lambda (attr)
- (cond ((string? attr) (push " ") (push attr))
- (attr (gnc:warn "non-string attribute" attr)))))
- (build-first-tag
- (lambda (tag)
- (push "<") (push tag)
- (if attr (hash-fold add-attribute #f attr))
- (if extra-attrib (for-each addextraatt extra-attrib))
- (if (not end-tag?)
- (push " /")) ;;add closing "/" for no-end elements...
- (push ">"))))
- (if tag
- (if (list? tag)
- (begin
- (build-first-tag (car tag))
- (for-each add-internal-tag (cdr tag)))
- (build-first-tag tag)))
- ;; XXX Font styling should be done through CSS, NOT html code
- ;; XXX Also, why is this even here? 'Font' is an html tag just like anything else,
- ;; so why does it have it's own custom pseudo code here? It should be built
- ;; as a call to this function just like any other tag, passing face/size/color as attributes.
- (if (or face size color)
- (begin
- (issue-deprecation-warning
- "this section is unreachable in code")
- (push "")))
- retval))))
+ (let* ((childinfo (gnc:html-document-fetch-markup-style doc markup))
+ (extra-attrib (and (pair? rest) rest))
+ (retval '())
+ (tag (or (gnc:html-markup-style-info-tag childinfo) markup))
+ (attr (gnc:html-markup-style-info-attributes childinfo))
+ (face (gnc:html-markup-style-info-font-face childinfo))
+ (size (gnc:html-markup-style-info-font-size childinfo))
+ (color (gnc:html-markup-style-info-font-color childinfo)))
+
+ (define (push l) (set! retval (cons l retval)))
+ (define (add-internal-tag tag) (push "<") (push tag) (push ">"))
+ (define (add-attribute key value)
+ (push " ") (push key)
+ (when value (push "=\"") (push value) (push "\"")))
+ (define (addextraatt attr)
+ (cond ((string? attr) (push " ") (push attr))
+ (attr (gnc:warn "non-string attribute" attr))))
+ (define (build-first-tag tag)
+ (push "<") (push tag)
+ (if attr (hash-for-each add-attribute attr))
+ (if extra-attrib (for-each addextraatt extra-attrib))
+ (unless end-tag? (push " /")) ;;add closing "/" for no-end elements...
+ (push ">"))
+
+ (match tag
+ ("" #f)
+ ((head . tail) (build-first-tag head) (for-each add-internal-tag tail))
+ (_ (build-first-tag tag)))
+
+ ;; XXX Font styling should be done through CSS, NOT html code
+ ;; XXX Also, why is this even here? 'Font' is an html tag just like anything else,
+ ;; so why does it have it's own custom pseudo code here? It should be built
+ ;; as a call to this function just like any other tag, passing face/size/color as attributes.
+ (if (or face size color)
+ (begin
+ (issue-deprecation-warning
+ "this section is unreachable in code")
+ (push "")))
+ retval))
(define (gnc:html-document-markup-end doc markup)
- (let ((childinfo (gnc:html-document-fetch-markup-style doc markup)))
+ (let* ((childinfo (gnc:html-document-fetch-markup-style doc markup))
+ (tag (or (gnc:html-markup-style-info-tag childinfo) markup))
+ (retval '()))
+ (define (push l) (set! retval (cons l retval)))
+ (define (addtag t)
+ (push "")
+ (push t)
+ (push ">\n"))
+ (when (gnc:html-markup-style-info-closing-font-tag childinfo)
+ (push "\n"))
;; now generate the end tag
- (let ((tag (gnc:html-markup-style-info-tag childinfo))
- (closing-font-tag
- (gnc:html-markup-style-info-closing-font-tag childinfo)))
- ;; "" tags mean "show no tag"; #f tags means use default.
- (cond ((not tag)
- (set! tag markup))
- ((and (string? tag) (string=? tag ""))
- (set! tag #f)))
- (let* ((retval '())
- (push (lambda (l) (set! retval (cons l retval)))))
- (if closing-font-tag
- (push "\n"))
- (if tag
- (let ((addtag (lambda (t)
- (push "")
- (push tag)
- (push ">\n"))))
- (cond
- ((string? tag)
- (addtag tag))
- ((list? tag)
- (for-each addtag (reverse tag))))))
- retval))))
+ ;; "" tags mean "show no tag"; #f tags means use default.)
+ (match tag
+ ("" #f)
+ ((? string?) (addtag tag))
+ ((? list?) (for-each addtag (reverse tag))))
+ retval))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-document-render-data
diff --git a/gnucash/report/report-system/trep-engine.scm b/gnucash/report/report-system/trep-engine.scm
index f39a47a7ba..0a10504de9 100644
--- a/gnucash/report/report-system/trep-engine.scm
+++ b/gnucash/report/report-system/trep-engine.scm
@@ -1939,18 +1939,14 @@ be excluded from periodic reporting.")
(define BOOK-SPLIT-ACTION
(qof-book-use-split-action-for-num-field (gnc-get-current-book)))
(define (is-filter-member split account-list)
- (let* ((txn (xaccSplitGetParent split))
- (splitcount (xaccTransCountSplits txn))
- (is-in-account-list? (lambda (acc) (member acc account-list))))
- (cond
- ((= splitcount 2)
- (is-in-account-list?
- (xaccSplitGetAccount (xaccSplitGetOtherSplit split))))
- ((> splitcount 2)
- (or-map is-in-account-list?
- (map xaccSplitGetAccount
- (delete split (xaccTransGetSplitList txn)))))
- (else #f))))
+ (define (same-split? s) (equal? s split))
+ (define (from-account? s) (member (xaccSplitGetAccount s) account-list))
+ (let lp ((splits (xaccTransGetSplitList (xaccSplitGetParent split))))
+ (match splits
+ (() #f)
+ (((? same-split?) . rest) (lp rest))
+ (((? from-account?) . _) #t)
+ ((_ . rest) (lp rest)))))
(gnc:report-starting (opt-val gnc:pagename-general gnc:optname-reportname))
diff --git a/gnucash/report/utility-reports/view-column.scm b/gnucash/report/utility-reports/view-column.scm
index df68cf689c..8d224f1c55 100644
--- a/gnucash/report/utility-reports/view-column.scm
+++ b/gnucash/report/utility-reports/view-column.scm
@@ -27,6 +27,7 @@
;; don't have to worry about that here.
(define-module (gnucash report view-column))
+(use-modules (ice-9 match))
(use-modules (gnucash utilities))
(use-modules (gnucash app-utils))
(use-modules (gnucash gnc-module))
@@ -86,20 +87,14 @@
;; make sure each subreport has an option change callback that
;; pings the parent
- (let loop ((new-reports '())
- (reports reports))
- (if (null? reports)
- (gnc:option-set-value report-opt (reverse new-reports))
- (let* ((report-info (car reports))
- (child (car report-info))
- (rowspan (cadr report-info))
- (colspan (caddr report-info))
- (callback (or (cadddr report-info)
- (make-child-options-callback
- report (gnc-report-find child)))))
- (loop (cons (list child rowspan colspan callback)
- new-reports)
- (cdr reports)))))
+ (let loop ((reports reports) (new-reports '()))
+ (match reports
+ (() (gnc:option-set-value report-opt (reverse new-reports)))
+ (((child rowspan colspan callback) . rest)
+ (let ((callback (or callback
+ (make-child-options-callback
+ report (gnc-report-find child)))))
+ (loop rest (cons (list child rowspan colspan callback) new-reports))))))
;; we really would rather do something smart here with the
;; report's cached text if possible. For the moment, we'll have
@@ -217,17 +212,11 @@
(define (cleanup-options report)
(let* ((options (gnc:report-options report))
(report-opt (gnc:lookup-option options "__general" "report-list")))
- (let loop ((new-reports '())
- (reports (gnc:option-value report-opt)))
- (if (null? reports)
- (gnc:option-set-value report-opt (reverse new-reports))
- (let* ((report-info (car reports))
- (child (car report-info))
- (rowspan (cadr report-info))
- (colspan (caddr report-info)))
- (loop (cons (list child rowspan colspan #f)
- new-reports)
- (cdr reports)))))))
+ (let loop ((reports (gnc:option-value report-opt)) (new-reports '()))
+ (match reports
+ (() (gnc:option-set-value report-opt (reverse new-reports)))
+ (((child rowspan colspan _) . rest)
+ (loop rest (cons (list child rowspan colspan #f) new-reports)))))))
;; define the view now.
(gnc:define-report