mirror of https://github.com/Gnucash/gnucash
Geert Janssens
7 years ago
parent
306964797b
commit
30ac2cf266
@ -1,351 +0,0 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2 of
|
||||
;; the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; if not, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
|
||||
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-module (gnucash report report-system collectors))
|
||||
|
||||
(issue-deprecation-warning
|
||||
"(gnucash report report-system collectors) is deprecated.")
|
||||
|
||||
(use-modules (srfi srfi-1))
|
||||
|
||||
(export make-filter)
|
||||
(export filter-satisfies)
|
||||
(export filter-id)
|
||||
(export assert-filter)
|
||||
(export make-equal-filter)
|
||||
(export make-predicate-filter)
|
||||
|
||||
(export make-collector)
|
||||
(export collector-accumulate-from)
|
||||
(export collector-count-from)
|
||||
(export collector-into-list)
|
||||
(export collector-per-property)
|
||||
(export collector-filtered-list)
|
||||
(export collector-split)
|
||||
(export make-mapper-collector)
|
||||
(export make-list-collector)
|
||||
(export collector-from-slotset)
|
||||
(export labelled-collector-from-slotset)
|
||||
(export collector-add)
|
||||
(export collector-end)
|
||||
(export assert-collector)
|
||||
(export collector-add-all)
|
||||
(export collector-where)
|
||||
(export collector-reformat)
|
||||
(export collector-print)
|
||||
(export collector-do)
|
||||
(export function-state->collector)
|
||||
(export make-eq-set-collector)
|
||||
(export make-extreme-collector)
|
||||
|
||||
(export make-slotset)
|
||||
(export slotset?)
|
||||
(export slotset-slots)
|
||||
(export slotset-slot)
|
||||
(export hashmap->slotset)
|
||||
(export alist->slotset)
|
||||
(export slotset-check)
|
||||
(export slotset-map-input)
|
||||
|
||||
(export binary-search-lt)
|
||||
|
||||
;; Filters
|
||||
(define (make-filter id predicate)
|
||||
(list 'filter id predicate))
|
||||
|
||||
(define (filter? filter)
|
||||
(eq? (car filter) 'filter))
|
||||
|
||||
(define (assert-filter filter)
|
||||
(if (filter? filter) #t
|
||||
(throw (list "not a filter" filter))))
|
||||
|
||||
(define (filter-satisfies filter object)
|
||||
(assert-filter filter)
|
||||
(let ((predicate (third filter)))
|
||||
(predicate object)))
|
||||
|
||||
(define (filter-id filter)
|
||||
(assert-filter filter)
|
||||
(second filter))
|
||||
|
||||
(define (make-predicate-filter id predicate)
|
||||
(make-filter id predicate))
|
||||
|
||||
|
||||
(define (make-equal-filter x)
|
||||
(make-filter x
|
||||
(lambda (value)
|
||||
(equal? x value))))
|
||||
|
||||
;;
|
||||
;; SlotSet
|
||||
;;
|
||||
|
||||
(define (make-slotset value->slot slots)
|
||||
(if (not (procedure? value->slot))
|
||||
(throw 'not-a-procedure value->slot))
|
||||
(if (not (pair? slots))
|
||||
(throw 'not-a-list slots))
|
||||
(list 'slotset value->slot slots))
|
||||
|
||||
(define (slotset? slotset)
|
||||
(eq? (car slotset) 'slotset))
|
||||
|
||||
(define (assert-slotset slotset)
|
||||
(if (slotset? slotset) #t
|
||||
(throw (list "not a slotset" slotset))))
|
||||
|
||||
(define (slotset-slots slotset)
|
||||
(assert-slotset slotset)
|
||||
(third slotset))
|
||||
|
||||
(define (slotset-slot slotset value)
|
||||
(assert-slotset slotset)
|
||||
((second slotset) value))
|
||||
|
||||
(define (slotset-map-input mapfn orig-slotset)
|
||||
(let ((orig-slotset-slot (second orig-slotset))
|
||||
(orig-slotset-slots (third orig-slotset)))
|
||||
(make-slotset (lambda (v) (orig-slotset-slot (mapfn v)))
|
||||
orig-slotset-slots)))
|
||||
|
||||
(define (hashmap->slotset hashmap)
|
||||
(make-slotset (lambda (v)
|
||||
(hash-ref hashmap v))
|
||||
(hashmap->list (lambda (key value) value) hashmap)))
|
||||
|
||||
(define (alist->slotset alist)
|
||||
(make-slotset (lambda (v) (assoc-ref alist v))
|
||||
(hash-map->list (lambda (key value) key)
|
||||
(fold (lambda (val h)
|
||||
(hash-set! h val val)
|
||||
h)
|
||||
(make-hash-table)
|
||||
(map cdr alist)))))
|
||||
|
||||
(define (slotset-check slotset)
|
||||
(assert-slotset slotset)
|
||||
(make-slotset (lambda (value)
|
||||
(let ((result (slotset-slot value)))
|
||||
(if (member result (third slotset))
|
||||
(throw (list 'slotset-to-non-value))
|
||||
result)))
|
||||
(third slotset)))
|
||||
;;
|
||||
;; Collectors
|
||||
;;
|
||||
|
||||
(define (make-collector f1 f2)
|
||||
(list 'collector f1 f2))
|
||||
|
||||
(define (collector-add collector value)
|
||||
(assert-collector collector)
|
||||
(let ((result ((second collector) value)))
|
||||
(assert-collector result)
|
||||
result))
|
||||
|
||||
(define (collector-end collector)
|
||||
(assert-collector collector)
|
||||
(let ((fn (third collector)))
|
||||
(fn)))
|
||||
|
||||
(define (collector-print stream name collector)
|
||||
(make-collector (lambda (value) (format stream "(add ~a ~a)\n" name value)
|
||||
(collector-print stream name (collector-add collector value)))
|
||||
(lambda () (let ((result (collector-end collector)))
|
||||
(format stream "(result ~a ~a)\n" name result)
|
||||
result))))
|
||||
|
||||
|
||||
(define (collector? collector)
|
||||
(and (list? collector)
|
||||
(eq? (car collector) 'collector)))
|
||||
|
||||
(define (assert-collector collector)
|
||||
(if (collector? collector) #t
|
||||
(throw 'error (list "not a collector" collector))))
|
||||
|
||||
(define (collector-add-all collector values)
|
||||
(if (null-list? values) (collector-end collector)
|
||||
(collector-add-all (collector-add collector (car values))
|
||||
(cdr values))))
|
||||
|
||||
(define (collector-accumulate-from total)
|
||||
(make-collector (lambda (x) (collector-accumulate-from (+ total x)))
|
||||
(lambda () total)))
|
||||
|
||||
(define (collector-count-from total)
|
||||
(make-collector (lambda (x) (collector-count-from (+ total 1)))
|
||||
(lambda () total)))
|
||||
|
||||
(define (collector-into-list)
|
||||
(define (collect-into l)
|
||||
(make-collector (lambda (x) (collect-into (cons x l)))
|
||||
(lambda () (reverse! l))))
|
||||
(collect-into '()))
|
||||
|
||||
(define (collector-per-property items make-property-filter make-per-property-collector)
|
||||
(let ((collectors (map (lambda (item)
|
||||
(cons (make-property-filter item)
|
||||
(make-per-property-collector item)))
|
||||
items)))
|
||||
(collector-filtered-list collectors)))
|
||||
|
||||
(define (collector-filtered-list filter-collector-pairs)
|
||||
(define (mapfn sublist value)
|
||||
(let ((pair (car sublist))
|
||||
(rest (cdr sublist)))
|
||||
(if (filter-satisfies (car pair) value)
|
||||
(cons (cons (car pair) (collector-add (cdr pair) value))
|
||||
rest)
|
||||
(cons pair (mapfn rest value)))))
|
||||
(make-collector
|
||||
(lambda (value)
|
||||
(collector-filtered-list (mapfn filter-collector-pairs value)))
|
||||
(lambda () (map (lambda (pair)
|
||||
(cons (filter-id (car pair))
|
||||
(collector-end (cdr pair))))
|
||||
filter-collector-pairs))))
|
||||
|
||||
;; Breaks a sequence of items into a list of collectors by property
|
||||
|
||||
(define (collector-split prop-fn make-per-split-collector)
|
||||
(let ((list '()))
|
||||
(define collector (make-collector (lambda (value)
|
||||
(let* ((prop (prop-fn value))
|
||||
(elt (assoc prop list)))
|
||||
(if elt
|
||||
(begin
|
||||
(set-cdr! elt (collector-add (cdr elt) value))
|
||||
collector)
|
||||
(begin (set! list (cons (cons prop
|
||||
(collector-add (make-per-split-collector prop)
|
||||
value))
|
||||
list))
|
||||
collector))))
|
||||
(lambda ()
|
||||
(map (lambda (pair) (cons (car pair)
|
||||
(collector-end (cdr pair))))
|
||||
list))))
|
||||
collector))
|
||||
|
||||
(define (make-eq-set-collector list)
|
||||
(define collector (make-collector
|
||||
(lambda (value)
|
||||
(if (memq value list) collector
|
||||
(make-eq-set-collector (cons value list))))
|
||||
(lambda () list)))
|
||||
collector)
|
||||
|
||||
(define (make-extreme-collector ordering current)
|
||||
(define collector (make-collector (lambda (value)
|
||||
(if (ordering value current)
|
||||
(make-extreme-collector ordering value)
|
||||
collector))
|
||||
(lambda () current)))
|
||||
collector)
|
||||
|
||||
|
||||
(define (collector-where pred collector)
|
||||
(define new-collector
|
||||
(make-collector (lambda (value)
|
||||
(if (pred value)
|
||||
(begin ;(format #t "accept ~a\n" value)
|
||||
(collector-where pred
|
||||
(collector-add collector value)))
|
||||
new-collector))
|
||||
(lambda () (collector-end collector))))
|
||||
new-collector)
|
||||
|
||||
(define (make-mapper-collector mapfn collector)
|
||||
(make-collector (lambda (value)
|
||||
(make-mapper-collector mapfn (collector-add collector (mapfn value))))
|
||||
(lambda () (collector-end collector))))
|
||||
|
||||
(define (collector-reformat formatter collector)
|
||||
(make-collector (lambda (value)
|
||||
(collector-reformat formatter (collector-add collector value)))
|
||||
(lambda () (formatter (collector-end collector)))))
|
||||
|
||||
|
||||
(define (make-list-collector collectors)
|
||||
(make-collector (lambda (value)
|
||||
(make-list-collector (map (lambda (inner-collector)
|
||||
(collector-add inner-collector value))
|
||||
collectors)))
|
||||
(lambda () (map collector-end collectors))))
|
||||
|
||||
|
||||
(define (collector-from-slotset slotset slot-collector)
|
||||
(define (make-table)
|
||||
(let ((valuemap (make-hash-table)))
|
||||
(for-each (lambda (slot)
|
||||
(hash-set! valuemap slot (slot-collector slot)))
|
||||
(slotset-slots slotset))
|
||||
valuemap))
|
||||
(let ((valuemap (make-table)))
|
||||
(define collector
|
||||
(make-collector (lambda (value)
|
||||
(let* ((slot (slotset-slot slotset value)))
|
||||
(hash-set! valuemap slot
|
||||
(collector-add (hash-ref valuemap slot)
|
||||
value)))
|
||||
collector)
|
||||
(lambda () (map (lambda (slot)
|
||||
(collector-end (hash-ref valuemap slot)))
|
||||
(slotset-slots slotset)))))
|
||||
collector))
|
||||
|
||||
(define (labelled-collector-from-slotset slotset slot-collector)
|
||||
(collector-from-slotset slotset
|
||||
(lambda (slot)
|
||||
(collector-reformat (lambda (result)
|
||||
(cons slot result))
|
||||
(slot-collector slot)))))
|
||||
|
||||
|
||||
(define (function-state->collector fn state)
|
||||
(make-collector (lambda (value)
|
||||
(let ((next (fn value state)))
|
||||
(function-state->collector fn next)))
|
||||
(lambda ()
|
||||
state)))
|
||||
|
||||
(define (collector-do collector . other-collectors)
|
||||
(collector-reformat (lambda (final)
|
||||
(car final))
|
||||
(make-list-collector (cons collector other-collectors))))
|
||||
|
||||
|
||||
;; Binary search. Returns highest index with content less than or
|
||||
;; equal to the supplied value.
|
||||
|
||||
(define (binary-search-lt <= val vec)
|
||||
(and (not (zero? (vector-length vec)))
|
||||
(let loop ((low 0)
|
||||
(high (1- (vector-length vec))))
|
||||
(let* ((midpoint (ceiling (/ (+ low high) 2)))
|
||||
(midvalue (vector-ref vec midpoint)))
|
||||
(if (= low high)
|
||||
(and (<= midvalue val)
|
||||
low)
|
||||
(if (<= midvalue val)
|
||||
(loop midpoint high)
|
||||
(loop low (1- midpoint))))))))
|
||||
@ -1,231 +0,0 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2 of
|
||||
;; the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; if not, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
|
||||
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-module (gnucash report report-system report-collectors))
|
||||
|
||||
(issue-deprecation-warning
|
||||
"(gnucash report report-system report-collectors) is deprecated.")
|
||||
|
||||
(use-modules (gnucash gnc-module))
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
(use-modules (ice-9 format))
|
||||
(use-modules (srfi srfi-1))
|
||||
|
||||
(use-modules (gnucash utilities))
|
||||
(use-modules (gnucash report report-system))
|
||||
(use-modules (gnucash app-utils))
|
||||
(use-modules (gnucash engine))
|
||||
(use-modules (gnucash report report-system collectors))
|
||||
|
||||
(export account-destination-alist)
|
||||
(export category-by-account-report)
|
||||
(export category-by-account-report-work)
|
||||
(export category-by-account-report-do-work)
|
||||
(export make-gnc-collector-collector)
|
||||
|
||||
(export splits-up-to)
|
||||
(export split->commodity)
|
||||
|
||||
(define (split->commodity split)
|
||||
(xaccAccountGetCommodity (xaccSplitGetAccount split)))
|
||||
|
||||
(define (split->date split)
|
||||
(xaccTransGetDate (xaccSplitGetParent split)))
|
||||
|
||||
(define (split->account split)
|
||||
(xaccSplitGetAccount split))
|
||||
|
||||
(define (split-closing? split)
|
||||
(xaccTransGetIsClosingTxn (xaccSplitGetParent split)))
|
||||
|
||||
(define (splits-up-to accounts startdate enddate)
|
||||
(gnc:account-get-trans-type-splits-interval accounts #f
|
||||
startdate
|
||||
enddate))
|
||||
|
||||
(define (make-gnc-collector-collector)
|
||||
(let ((gnc-collector (gnc:make-commodity-collector)))
|
||||
(define collector
|
||||
(make-collector (lambda (split)
|
||||
(let* ((shares (xaccSplitGetAmount split))
|
||||
(acct-comm (split->commodity split)))
|
||||
(gnc-collector 'add acct-comm shares)
|
||||
collector))
|
||||
(lambda () gnc-collector)))
|
||||
collector))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Plan:
|
||||
;; We create reports via collectors - effectively per account, per date stores of values.
|
||||
;; Values are held as report-system/collector objects (sorry about the name reuse..),
|
||||
;; which can then be evaluated by a collector-reformat step.
|
||||
;;
|
||||
;; For a given report, we want to retrieve relevant transactions once
|
||||
;; (this is the splits-up-to function), and then push the transactions
|
||||
;; into a collector structure. This way there's no O(n^2) or worse
|
||||
;; complexity.
|
||||
|
||||
(define (build-account-collector account-destination-alist
|
||||
per-account-collector)
|
||||
(let ((slotset (slotset-map-input split->account
|
||||
(alist->slotset account-destination-alist))))
|
||||
(collector-from-slotset slotset per-account-collector)))
|
||||
|
||||
(define (build-date-collector dates per-date-collector)
|
||||
(let* ((date-vector (list->vector dates))
|
||||
(slotset (make-slotset (lambda (split)
|
||||
(let* ((date (split->date split))
|
||||
(interval-index (binary-search-lt (lambda (pair date)
|
||||
(or (not (car pair))
|
||||
(<= (car pair) date)))
|
||||
date
|
||||
date-vector))
|
||||
(interval (vector-ref date-vector interval-index)))
|
||||
interval))
|
||||
dates)))
|
||||
(collector-from-slotset slotset per-date-collector)))
|
||||
|
||||
(define (build-category-by-account-collector account-destination-alist dates cell-accumulator result-collector)
|
||||
(build-account-collector account-destination-alist
|
||||
(lambda (account)
|
||||
(collector-reformat (lambda (result)
|
||||
(list account (result-collector account result)))
|
||||
(build-date-collector dates
|
||||
(lambda (date)
|
||||
(cell-accumulator account date)))))))
|
||||
|
||||
(define (category-by-account-report do-intervals? datepairs account-alist
|
||||
split-collector result-collector progress-range)
|
||||
(let* ((work (category-by-account-report-work do-intervals? datepairs
|
||||
account-alist split-collector result-collector))
|
||||
(splits-fn (car work))
|
||||
(collector (cdr work))
|
||||
(splits (splits-fn)))
|
||||
(collector-add-all (collector-do collector
|
||||
(progress-collector (length splits) progress-range))
|
||||
splits)))
|
||||
|
||||
(define (category-by-account-report-do-work work progress-range)
|
||||
(let* ((splits-fn (car work))
|
||||
(collector (cdr work))
|
||||
(splits (splits-fn)))
|
||||
(collector-add-all (collector-do collector
|
||||
(progress-collector (length splits) progress-range))
|
||||
splits)))
|
||||
|
||||
;; Decide how to run the given report (but don't actually do any work)
|
||||
|
||||
(define (category-by-account-report-work do-intervals? dates account-alist
|
||||
split-collector result-collector)
|
||||
(let* ((dateinfo (if do-intervals?
|
||||
(category-report-dates-intervals dates)
|
||||
(category-report-dates-accumulate dates)))
|
||||
(processed-dates (third dateinfo))
|
||||
(splits-fn (lambda () (category-report-splits dateinfo account-alist)))
|
||||
(collector (collector-where (lambda (split) (not (split-closing? split)))
|
||||
(build-category-by-account-collector account-alist
|
||||
processed-dates split-collector
|
||||
result-collector))))
|
||||
(cons splits-fn collector)))
|
||||
|
||||
(define (category-report-splits dateinfo account-alist)
|
||||
(let ((min-date (first dateinfo))
|
||||
(max-date (second dateinfo)))
|
||||
(splits-up-to (map car account-alist) min-date max-date)))
|
||||
|
||||
(define (category-report-dates-intervals dates)
|
||||
(let* ((min-date (apply min (map first dates)))
|
||||
(max-date (apply max (map second dates))))
|
||||
(list min-date max-date dates)))
|
||||
|
||||
(define (category-report-dates-accumulate dates)
|
||||
(let* ((min-date #f)
|
||||
(max-date (apply max dates))
|
||||
(datepairs (reverse! (cdr (fold (lambda (next acc)
|
||||
(let ((prev (car acc))
|
||||
(pairs-so-far (cdr acc)))
|
||||
(cons next (cons (list prev next) pairs-so-far))))
|
||||
(cons min-date '()) dates)))))
|
||||
(list min-date max-date datepairs)))
|
||||
|
||||
|
||||
|
||||
(define (progress-collector size range)
|
||||
(let* ((from (car range))
|
||||
(to (cdr range))
|
||||
(width (- to from)))
|
||||
(define (count->percentage count)
|
||||
(+ (* width (/ count size)) from))
|
||||
(function-state->collector (lambda (value state)
|
||||
(let ((last (floor (count->percentage (- state 1))))
|
||||
(next (floor (count->percentage state))))
|
||||
(if (not (= last next))
|
||||
(gnc:report-percent-done (+ (* width (/ state size)) from)))
|
||||
(+ state 1)))
|
||||
0)))
|
||||
|
||||
(define (gnc-account-child-accounts-recursive account)
|
||||
(define (helper account initial)
|
||||
(fold (lambda (child-account accumulator)
|
||||
(append (helper child-account (list child-account))
|
||||
accumulator))
|
||||
initial
|
||||
(gnc-account-get-children account)))
|
||||
(helper account '()))
|
||||
|
||||
(define (traverse-accounts tree-depth show-acct? account-types)
|
||||
(define (inner-traverse-accounts current-depth accounts)
|
||||
(if (< current-depth tree-depth)
|
||||
(let ((res '()))
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(begin
|
||||
(if (show-acct? a)
|
||||
(set! res
|
||||
(cons (cons a a) res)))
|
||||
(set! res (append
|
||||
(inner-traverse-accounts
|
||||
(+ 1 current-depth)
|
||||
(gnc-account-get-children a))
|
||||
res))))
|
||||
accounts)
|
||||
res)
|
||||
;; else (i.e. current-depth == tree-depth)
|
||||
(fold (lambda (account acc)
|
||||
(let ((child-accounts (gnc-account-child-accounts-recursive account)))
|
||||
(append (map (lambda (child-account)
|
||||
(cons child-account account))
|
||||
child-accounts)
|
||||
(list (cons account account))
|
||||
acc)))
|
||||
'()
|
||||
(filter show-acct? accounts))))
|
||||
(let* ((topl-accounts (gnc:filter-accountlist-type
|
||||
account-types
|
||||
(gnc-account-get-children-sorted
|
||||
(gnc-get-current-root-account))))
|
||||
(account-head-list (inner-traverse-accounts 1 topl-accounts)))
|
||||
account-head-list))
|
||||
|
||||
(define (account-destination-alist accounts account-types tree-depth)
|
||||
(define (show-acct? a)
|
||||
(member a accounts))
|
||||
(traverse-accounts tree-depth show-acct? account-types))
|
||||
@ -1,23 +0,0 @@
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2 of
|
||||
;; the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; if not, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
|
||||
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
||||
|
||||
(define (gnc:hook-run-danglers hook . args)
|
||||
(issue-deprecation-warning "gnc:hook-run-danglers is now deprecated.")
|
||||
(if (null? args)
|
||||
(set! args '())
|
||||
(set! args (car args)))
|
||||
(gnc-hook-run hook args))
|
||||
@ -1,52 +0,0 @@
|
||||
(use-modules (gnucash gnc-module))
|
||||
|
||||
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
|
||||
|
||||
(use-modules (gnucash engine))
|
||||
|
||||
(use-modules (tests test-engine-extras))
|
||||
|
||||
;; this test suite tests deprecated functions.
|
||||
|
||||
(define (run-test)
|
||||
(test test-account-same?)
|
||||
(test test-account-in-list?)
|
||||
(test test-account-in-alist?)
|
||||
(test test-account-list-predicate))
|
||||
|
||||
(define (test-account-same?)
|
||||
(let* ((env (create-test-env))
|
||||
(account-alist (env-create-test-accounts env))
|
||||
(bank-account (cdr (assoc "Bank" account-alist)))
|
||||
(expense-account (cdr (assoc "Expenses" account-alist))))
|
||||
(and (account-same? bank-account bank-account)
|
||||
(not (account-same? bank-account expense-account)))))
|
||||
|
||||
(define (test-account-in-alist?)
|
||||
(let* ((env (create-test-env))
|
||||
(account-alist (env-create-test-accounts env))
|
||||
(bank-account (cdr (assoc "Bank" account-alist)))
|
||||
(wallet-account (cdr (assoc "Wallet" account-alist)))
|
||||
(expense-account (cdr (assoc "Expenses" account-alist))))
|
||||
(let ((alist (list (cons bank-account "Bank") (cons expense-account "Expenses"))))
|
||||
(and (account-in-alist bank-account alist)
|
||||
(account-in-alist expense-account alist)
|
||||
(not (account-in-alist wallet-account alist))))))
|
||||
|
||||
(define (test-account-in-list?)
|
||||
(test-account-list-predicate-generic
|
||||
(lambda (accounts) (lambda (account) (account-in-list? account accounts)))))
|
||||
|
||||
(define (test-account-list-predicate)
|
||||
(test-account-list-predicate-generic account-in-list-pred))
|
||||
|
||||
(define (test-account-list-predicate-generic predicate)
|
||||
(let* ((env (create-test-env))
|
||||
(account-alist (env-create-test-accounts env))
|
||||
(bank-account (cdr (assoc "Bank" account-alist)))
|
||||
(wallet-account (cdr (assoc "Wallet" account-alist)))
|
||||
(other-account (cdr (assoc "Other" account-alist)))
|
||||
(bank-or-wallet? (predicate (list bank-account wallet-account))))
|
||||
(and (bank-or-wallet? bank-account)
|
||||
(bank-or-wallet? wallet-account)
|
||||
(not (bank-or-wallet? other-account)))))
|
||||
@ -1,29 +0,0 @@
|
||||
(use-modules (gnucash gnc-module))
|
||||
(use-modules (srfi srfi-1))
|
||||
|
||||
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
|
||||
|
||||
(use-modules (gnucash engine))
|
||||
(use-modules (tests test-engine-extras))
|
||||
(use-modules (gnucash app-utils))
|
||||
|
||||
(define (run-test)
|
||||
(test test-split-in-list?))
|
||||
|
||||
(define (test-split-in-list?)
|
||||
;; this test suite tests deprecated functions.
|
||||
(let* ((env (create-test-env))
|
||||
(today (current-time))
|
||||
(account-alist (env-create-test-accounts env))
|
||||
(bank-account (cdr (assoc "Bank" account-alist)))
|
||||
(expense-account (cdr (assoc "Expenses" account-alist)))
|
||||
(wallet-account (cdr (assoc "Wallet" account-alist)))
|
||||
(tx1 (env-create-transaction env today bank-account wallet-account 20/1))
|
||||
(tx2 (env-create-transaction env today bank-account expense-account 10/1))
|
||||
(splits-tx1 (xaccTransGetSplitList tx1))
|
||||
(splits-tx2 (xaccTransGetSplitList tx2)))
|
||||
(and (split-in-list? (first splits-tx1) splits-tx1)
|
||||
(split-in-list? (second splits-tx1) splits-tx1)
|
||||
(not (split-in-list? (first splits-tx1) splits-tx2))
|
||||
(not (split-in-list? (second splits-tx1) splits-tx2))
|
||||
(not (split-in-list? (first splits-tx1) '())))))
|
||||
Loading…
Reference in new issue