Skip to content

Commit

Permalink
compact, use (ice-9 match)
Browse files Browse the repository at this point in the history
  • Loading branch information
@christopherlam
christopherlam committed Feb 15, 2020
1 parent b23d244 commit 3ac60ed
Show file tree
Hide file tree
Showing 3 changed files with 88 additions and 123 deletions.
152 changes: 66 additions & 86 deletions gnucash/report/report-system/html-document.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(gnc:module-load "gnucash/html" 0)
(use-modules (ice-9 match))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-document> class
Expand Down Expand Up @@ -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
Expand Down
20 changes: 8 additions & 12 deletions gnucash/report/report-system/trep-engine.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))

Expand Down
39 changes: 14 additions & 25 deletions gnucash/report/utility-reports/view-column.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 3ac60ed

Please sign in to comment.