From 3ac60ed2e427816fcbc70b7f757b617510caef45 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Sun, 9 Feb 2020 18:20:41 +0800 Subject: [PATCH] compact, use (ice-9 match) --- .../report/report-system/html-document.scm | 152 ++++++++---------- gnucash/report/report-system/trep-engine.scm | 20 +-- .../report/utility-reports/view-column.scm | 39 ++--- 3 files changed, 88 insertions(+), 123 deletions(-) diff --git a/gnucash/report/report-system/html-document.scm b/gnucash/report/report-system/html-document.scm index 3744eb79add..ef050a19793 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 "\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 "\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 f39a47a7ba4..0a10504de98 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 df68cf689cc..8d224f1c55b 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