compact, use (ice-9 match)

gnucash/report/report-system/html-document.scm

@@ -22,6 +22,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (gnc:module-load "gnucash/html" 0)
+(use-modules (ice-9 match))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;  <html-document> 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 "<font ")
-              (if face
-                  (begin
-                    (push "face=\"") (push face) (push "\" ")))
-              (if size
-                  (begin
-                    (push "size=\"") (push size) (push "\" ")))
-              (if color
-                  (begin
-                    (push "color=\"") (push color) (push "\" ")))
-              (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 "<font ")
+          (if face
+              (begin
+                (push "face=\"") (push face) (push "\" ")))
+          (if size
+              (begin
+                (push "size=\"") (push size) (push "\" ")))
+          (if color
+              (begin
+                (push "color=\"") (push color) (push "\" ")))
+          (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 "</font>\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 "</font>\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

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))
 

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