IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Add some plumbing for report changes - test framework plus some utility methods

Browse Source 
Author:    Peter Broadbery <p.broadbery@gmail.com>

git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@23021 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Geert Janssens
2013-06-02 10:31:26 +00:00
parent 056545fcf8
commit c57a3ee516
8 changed files with 1048 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
src/report/report-system/Makefile.am
View File

@@ -54,10 +54,17 @@ gncscm_DATA = \
html-jqplot.scm \
options-utilities.scm \
report-utilities.scm \
report.scm
report.scm
gncmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report-system
gncmodscmdir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/report-system
gncmodscm_DATA = \
collectors.scm \
list-extras.scm
gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/
gncscmmod_DATA = \
report-system.scm \
@@ -70,19 +77,22 @@ if GNUCASH_SEPARATE_BUILDDIR
# for running
SCM_FILE_LINKS = \
${gncscmmod_DATA} \
${gncscm_DATA}
${gncscm_DATA} \
${gncmodscm_DATA}
endif
.scm-links:
$(RM) -rf gnucash
mkdir -p gnucash
mkdir -p gnucash/report
mkdir -p gnucash/report/report-system
if GNUCASH_SEPARATE_BUILDDIR
for X in ${SCM_FILE_LINKS} ; do \
$(LN_S) -f ${srcdir}/$$X . ; \
done
endif
( cd gnucash/report; for A in $(gncscmmod_DATA) ; do $(LN_S) -f ../../$$A . ; done )
( cd gnucash/report/report-system; for A in $(gncmodscm_DATA) ; do $(LN_S) -f ../../../$$A . ; done )
if ! OS_WIN32
# Windows knows no "ln -s" but uses "cp": must copy every time (see bug #566567).
touch .scm-links

330
src/report/report-system/collectors.scm Normal file
View File

@@ -0,0 +1,330 @@
(define-module (gnucash report report-system collectors))
(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-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 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 predicate-and)
(export predicate-or)
(export predicate-not)
(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-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)))))
;;
;; Predicates
;;
;; Was thinking about turning these into a real type (just to get a
;; decent predicate-name function). Probably not required.
(define (predicate-not p)
(lambda (x) (not (p x))))
(define (predicate-and p1 p2)
(lambda (x) (and (p1 x) (p2 x))))
(define (predicate-or p1 p2)
(lambda (x) (or (p1 x) (p2 x))))
(define (make-predicate fn) fn)
(define (predicate-test p value)
(p value))
;; Binary search. Returns highest index with content less than or
;; equal to the supplied value.
(define (binary-search-lt <= value vector)
(define (search low high)
(let* ((midpoint (+ low (ceiling (/ (- high low) 2))))
(midvalue (vector-ref vector midpoint)))
(if (= low high)
(if (<= midvalue value)
low #f)
(if (<= midvalue value)
(search midpoint high)
(search low (- midpoint 1))))))
(if (= 0 (vector-length vector)) #f
(search 0 (- (vector-length vector) 1))))

28
src/report/report-system/list-extras.scm Normal file
View File

@@ -0,0 +1,28 @@
(define-module (gnucash report report-system list-extras))
(use-modules (srfi srfi-1))
(export list-min-max)
(export list-leaves)
(export function-compose)
(define (list-min-max list ordered?)
(define (helper list min max)
(if (null? list) (cons min max)
(let ((elt (car list)))
(helper (cdr list)
(if (ordered? elt min) elt min)
(if (ordered? elt max) max elt)))))
(helper (cdr list) (car list) (car list)))
(define (list-leaves list)
(if (not (pair? list))
(cons list '())
(fold (lambda (next acc)
(append (list-leaves next)
acc))
'()
list)))
(define (function-compose f1 f2)
(lambda a
(f1 (apply f2 a))))

40
src/report/report-system/test/Makefile.am
View File

@@ -15,13 +15,20 @@ LDADD = \
TESTS = \
test-link-module \
test-load-module
test-load-module \
$(SCM_TESTS)
SCM_TESTS = \
test-collectors.scm \
test-list-extras.scm \
test-test-extras.scm
GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \
--gnc-module-dir ${top_builddir}/src/app-utils \
--gnc-module-dir ${top_builddir}/src/gnome-utils \
--gnc-module-dir ${top_builddir}/src/html \
--gnc-module-dir ${top_builddir}/src/report/report-system \
--gnc-module-dir ${top_builddir}/src/report/report-system/test \
\
--guile-load-dir ${top_builddir}/src/gnc-module \
--guile-load-dir ${top_builddir}/src/scm \
@@ -30,6 +37,7 @@ GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \
--guile-load-dir ${top_builddir}/src/app-utils \
--guile-load-dir ${top_builddir}/src/gnome-utils \
--guile-load-dir ${top_builddir}/src/report/report-system \
--guile-load-dir ${top_builddir}/src/report/report-system/test \
\
--library-dir ${top_builddir}/src/libqof/qof \
--library-dir ${top_builddir}/src/core-utils \
@@ -40,6 +48,10 @@ GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \
--library-dir ${top_builddir}/src/backend/sql \
--library-dir ${top_builddir}/src/gnc-module
$(SCM_TESTS): %.scm: Makefile
echo 'guile --debug -l $(srcdir)/$*.scm -c "(exit (run-test))"' > $@
chmod a+x $@
TESTS_ENVIRONMENT = \
GUILE_WARN_DEPRECATED=no \
GNC_BUILDDIR=`\cd ${top_builddir} && pwd` \
@@ -52,3 +64,29 @@ EXTRA_DIST = test-load-module
testit:
$(TESTS_ENVIRONMENT) libtool --mode execute gdb test-link-module
if GNUCASH_SEPARATE_BUILDDIR
SCM_FILE_LINKS = test-extras.scm
endif
.scm-links:
$(RM) -rf gnucash
mkdir -p gnucash/report/report-system/test
if GNUCASH_SEPARATE_BUILDDIR
for X in ${SCM_FILE_LINKS} ; do \
$(LN_S) -f ${srcdir}/$$X . ; \
done
endif
( cd gnucash/report/report-system/test; for A in $(SCM_FILE_LINKS) ; do $(LN_S) -f ../../../../$$A . ; done )
if ! OS_WIN32
# Windows knows no "ln -s" but uses "cp": must copy every time (see bug #566567).
touch .scm-links
endif
clean-local:
$(RM) -rf gnucash
noinst_DATA = .scm-links
CLEANFILES = .scm-links
DISTCLEANFILES = ${SCM_FILE_LINKS}

169
src/report/report-system/test/test-collectors.scm Normal file
View File

@@ -0,0 +1,169 @@
(use-modules (srfi srfi-1))
(use-modules (gnucash report report-system collectors))
(use-modules (gnucash report report-system test test-extras))
(define (run-test)
(and (test test-empty)
(test test-one)
(test test-two)
(test test-make-eq-set)
(test test-make-extreme-collector)
(test test-collector-split)
(test test-make-mapper-collector)
(test test-make-list-collector)
(test test-slotset)
(test test-collector-from-slotset)
(test test-binary-search-lt)
#t))
(define (test-slotset)
(let* ((values '(2 4 6))
(slotset (make-slotset (lambda (x) (* 2 x)) values)))
(and (equal? values (slotset-slots slotset))
(equal? 2 (slotset-slot slotset 1)))))
(define (test-empty)
(let ((c (empty-collector)))
(let ((empty (collector-end c)))
(and (equal? 4 (length empty))
(equal? 0 (collector-add-all (collector-accumulate-from 0)
(map cdr empty)))))))
(define (test-one)
(define c (empty-collector))
(set! c (collector-add c 1))
(and (equal? 1 (collector-add-all (collector-accumulate-from 0)
(map cdr (collector-end c))))
(equal? 4 (length (collector-end c)))))
(define (test-two)
(define c (empty-collector))
(set! c (collector-add c 2))
(and (equal? 2 (collector-add-all (collector-accumulate-from 0)
(map cdr (collector-end c))))
(equal? 4 (length (collector-end c)))))
(define (empty-collector)
(define ((equal-predicate a) x)
(equal? a x))
(collector-per-property '(1 2 3 4)
make-equal-filter
(lambda (value) (collector-accumulate-from 0))))
(define (test-make-eq-set)
(let ((c (make-eq-set-collector '())))
(and (null-list? (collector-end c))
(let ((c1 (collector-add c 1)))
(equal? '(1) (collector-end c1)))
(equal? '(1) (collector-add-all c '(1 1 1)))
(let ((result (collector-add-all c '(1 2))))
(and (member 1 result)
(member 2 result)
(= (length result) 2))))))
(define (test-make-extreme-collector)
(let ((c (make-extreme-collector > 0)))
(and (equal? 0 (collector-end c))
(equal? 0 (collector-add-all c '(-1)))
(equal? 1 (collector-add-all c '(1)))
(equal? 5 (collector-add-all c '(5)))
(equal? 5 (collector-add-all c '(1 5)))
(equal? 5 (collector-add-all c '(5 1)))
#t)))
(define (test-collector-split)
(let* ((c (collector-split (lambda (x) x)
(lambda (x) (collector-count-from 0))))
(all (collector-add-all c '(1 2 3 4 5 1 2))))
(and (equal? 5 (length all))
#t)))
(define (test-make-mapper-collector)
(let ((double-and-add (make-mapper-collector (lambda (x) (* x 2))
(collector-accumulate-from 0))))
(and (equal? 0 (collector-end double-and-add))
(equal? 2 (collector-add-all double-and-add '(1)))
#t)))
(define (test-make-list-collector)
(let ((c1 (collector-accumulate-from 0))
(c2 (collector-count-from 0)))
(and (equal? '(10 4) (collector-add-all (make-list-collector (list c1 c2)) '(1 2 3 4))))))
(define (test-collector-from-slotset)
;;(define (add-trace name collector)
;; (collector-print #t name collector))
(define (make-slotset-counter values)
(let ((slotset (make-slotset (lambda (x) x) values)))
(labelled-collector-from-slotset slotset
(lambda (n)
(collector-count-from 0)))))
(and (let ((values '(1 2)))
(equal? '((1 . 0) (2 . 0))
(collector-add-all (make-slotset-counter values)
'())))
(let ((values '(1 2)))
(equal? '((1 . 1) (2 . 1))
(collector-add-all (make-slotset-counter values)
'(1 2))))
(let ((values '(1 2)))
(equal? '((1 . 3) (2 . 2))
(collector-add-all (make-slotset-counter values)
'(1 2 1 2 1))))))
(use-modules (ice-9 streams))
(define (stream-range from to)
(make-stream (lambda (current)
(if (> current to) '()
(cons current (+ current 1))))
from))
(define (slow-search <= value vector)
(define (search n)
(if (= n (vector-length vector)) (- n 1)
(if (<= (vector-ref vector n) value)
(search (+ n 1))
(if (= n 0) #f (- n 1)))))
(if (= 0 (vector-length vector)) #f
(search 0)))
(define (test-binary-search-lt)
(define (search value vector)
(let ((binary-value (binary-search-lt <= value vector))
(slow-value (slow-search <= value vector))
(length (vector-length vector)))
(if (equal? binary-value slow-value) binary-value
(begin (format #t "Mismatch ~a ~a, expected ~a, found ~a\n" value vector slow-value binary-value)
(throw 'mismatch)))
binary-value))
(and (and (equal? #f (search 1 #()))
(equal? #f (search 0 #(1)))
(equal? 0 (search 1 #(1)))
(equal? 0 (search 2 #(1)))
(equal? #f (search 0 #(1 3)))
(equal? 0 (search 1 #(1 3)))
(equal? 0 (search 2 #(1 3)))
(equal? 1 (search 3 #(1 3)))
(equal? 1 (search 4 #(1 3))))
(let* ((values (stream-range 0 20))
(vectors (stream-map (lambda (n)
(let ((vector (make-vector n)))
(stream-for-each (lambda (index)
(vector-set! vector index (+ (* index 2) 1)))
(stream-range 0 (- n 1)))
vector))
values))
(tested-vectors (stream-map (lambda (vector)
(stream-for-each
(lambda (value)
(search value vector))
(stream-range 0 (+ (* (vector-length vector) 2) 1))))
vectors)))
(stream-for-each (lambda (x) x) tested-vectors))))

352
src/report/report-system/test/test-extras.scm Normal file
View File

@@ -0,0 +1,352 @@
(define-module (gnucash report report-system test test-extras))
(use-modules (gnucash gnc-module))
(gnc:module-load "gnucash/report/report-system" 0)
(use-modules (sw_engine))
(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
(use-modules (gnucash printf))
(use-modules (gnucash report report-system))
(use-modules (gnucash app-utils))
(use-modules (gnucash engine))
(use-modules (srfi srfi-1))
(export logging-and)
(export test)
(export make-test-sink)
(export env-test-sink)
(export test-sink-report)
(export test-sink-check)
(export delayed-format)
(export delayed-format-render)
(export with-account)
(export with-transaction)
(export create-test-env)
(export env-random-amount)
(export env-random)
(export env-counter-next)
(export env-string)
(export env-select-price-source)
(export env-any-date)
(export env-create-transaction)
(export env-create-account)
(export env-create-root-account)
(export env-create-daily-transactions)
(export env-create-account-structure)
(export env-expense-account-structure)
(export pattern-streamer)
(export create-option-set)
(export option-set-setter)
(export option-set-getter)
(export tbl-column-count)
(export tbl-row-count)
(export tbl-ref)
(export tbl-ref->number)
;;
;; Random test related syntax and the like
;;
;; logging-and is mostly for debugging tests
(define-macro (logging-and . args)
(cons 'and (map (lambda (arg)
(list 'begin
(list 'format #t "Test: ~a\n" (list 'quote arg))
arg))
args)))
;; ..and 'test' gives nicer output
(define (test the-test)
(format #t "(Running ~a " the-test)
(let ((result (the-test)))
(format #t "~a Completed)\n" result)
result))
;;
;; Gnucash specifics
;;
;; Really could do with generalising and making into a 'with' macro
(define (with-account account fn)
(begin (xaccAccountBeginEdit account)
(let ((result (fn)))
(xaccAccountCommitEdit account)
result)))
(define (with-accounts accounts fn)
(begin (map xaccAccountBeginEdit accounts)
(let ((result (fn)))
(map xaccAccountCommitEdit accounts)
result)))
(define (with-transaction txn fn)
(begin (xaccTransBeginEdit txn)
(let ((result (fn)))
(xaccTransCommitEdit txn)
result)))
;; Test environments.. an environment is just an alist with some well
;; known names. The idea is that we can use it to pass around
;; "suitable" sets of values for things
(define (make-counter)
(let ((x 0))
(lambda ()
(begin (set! x (+ x 1))
x))))
(define (create-test-env)
(list (cons 'random (seed->random-state (random 1000)))
(cons 'counter (make-counter))
(cons 'sink (make-test-sink))))
(define (env-random-amount env n)
(gnc:make-gnc-numeric (env-random env n) 1))
(define (env-random env n)
(random n (assoc-ref env 'random)))
(define (env-counter-next env)
((assoc-ref env 'counter)))
(define (env-string env prefix)
(format #f "~a-~a" prefix (env-counter-next env)))
(define (env-select-price-source env)
'pricedb-nearest)
(define (env-test-sink env)
(assoc-ref env 'sink))
(define (env-any-date env) (gnc:get-today))
(define (env-create-transaction env date credit debit aaa)
(let ((txn (xaccMallocTransaction (gnc-get-current-book)))
(split-1 (xaccMallocSplit (gnc-get-current-book)))
(split-2 (xaccMallocSplit (gnc-get-current-book)))
(localtime (gnc:timepair->date date)))
(format #t "amount ~a ~a\n" aaa debit)
(with-transaction txn
(lambda ()
(xaccTransSetDescription txn (env-string env "ponies"))
(xaccTransSetCurrency txn (gnc-default-report-currency))
(xaccTransSetDate txn
(gnc:date-get-month-day localtime)
(gnc:date-get-month localtime)
(gnc:date-get-year localtime))
(xaccSplitSetParent split-1 txn)
(xaccSplitSetParent split-2 txn)
(xaccSplitSetAccount split-1 credit)
(xaccSplitSetAccount split-2 debit)
(xaccSplitSetAmount split-1 aaa)
(xaccSplitSetAmount split-2 (gnc-numeric-neg aaa))
(xaccSplitSetValue split-1 aaa)
(xaccSplitSetValue split-2 (gnc-numeric-neg aaa))
))
;(format #t "tx ~a\n" (map xaccSplitGetAmount (list split-1 split-2)))
;(format #t "tx ~a\n" (map xaccSplitGetValue (list split-1 split-2)))
txn))
(define (env-create-root-account env type commodity)
(env-create-account env type commodity (gnc-get-current-root-account)))
(define (env-create-account env type commodity parent-account)
(let ((new-account (xaccMallocAccount (gnc-get-current-book))))
(with-accounts (list new-account parent-account)
(lambda ()
(xaccAccountSetCommodity new-account commodity)
(xaccAccountSetName new-account (env-string env "account"))
(xaccAccountSetType new-account type)
(gnc-account-append-child parent-account new-account)
new-account))))
;; Spend '1' on the 1st, '2' on the 2nd, etc. Makes for pretty graphs
(define (env-create-daily-transactions env start-date end-date to-account from-account)
(let ((dates-this-month (gnc:make-date-list start-date
end-date
DayDelta)))
(for-each (lambda (date)
(env-create-transaction env date to-account
from-account
(gnc:make-gnc-numeric
(gnc:date-get-month-day (gnc:timepair->date date))
1)))
(cdr (reverse dates-this-month)))))
(define (env-create-account-structure env account-structure)
(define (lookup-options list)
(if (null? list) (cons '() '())
(if (not (pair? (car list)))
(cons '() list)
(if (not (pair? (car (car list))))
(cons '() list)
list))))
(define (create-substructure parent options account-structure)
;;(format #t "Creating subaccounts for ~a ~a\n"
;; (xaccAccountGetName parent) account-structure)
(let* ((account-name (car account-structure))
(options-pair (lookup-options (cdr account-structure)))
(options (append (car options-pair) options)))
;;(format #t "New Account ~a\n" account-name)
;;(format #t "Options ~a\n" (car options-pair))
;;(format #t "Child list ~a\n" (cdr options-pair))
(let ((new-account (env-create-account env (assoc-ref options 'type)
(assoc-ref options 'commodity)
parent)))
(with-accounts (list new-account)
(lambda ()
(xaccAccountSetName new-account account-name)))
(cons new-account
(map (lambda (child)
(create-substructure new-account options child))
(cdr options-pair))))))
(let ((options (list (cons 'commodity (gnc-default-report-currency))
(cons 'type '()))))
(create-substructure (gnc-get-current-root-account)
options
account-structure)))
(define (env-expense-account-structure env)
(env-create-account-structure
env
(list "Expenses"
(list (cons 'type ACCT-TYPE-EXPENSE))
(list "Groceries")
(list "Rent")
(list "Auto"
(list "Tax")
(list "Parking")
(list "Petrol")))))
;; Date sequences
;;
;;
;; Table parsing
;;
(use-modules (ice-9 regex))
(use-modules (ice-9 streams))
(define (values-for-keywords pos regex-list text)
(make-stream (lambda (pos-keywords-pair)
(let ((current-pos (car pos-keywords-pair))
(regex-list (cdr pos-keywords-pair)))
(if (null? regex-list)
'()
(let ((match (string-match (caar regex-list) text current-pos)))
(if (not match)
'()
(let ((new-state (cons (match:end match)
(cdr regex-list)))
(next-value (cons (match:end match)
(map (lambda (item)
(match:substring match item))
(cdar regex-list)))))
(cons next-value new-state)))))))
(cons pos regex-list)))
(define (pattern-streamer start-text regex-list text)
(define (stream-next index)
;;(format #t "Next. Index: ~a\n" index)
(let ((head-index (string-contains text start-text index)))
;; (format #t "head index ~a ~a --> ~a\n" start-text index head-index)
(if (not head-index) '()
(let ((values (stream->list (values-for-keywords head-index regex-list text))))
(if (null? values) '()
(let ((new-state (car (car (last-pair values))))
(next-value (map cdr values)))
(cons next-value new-state)))))))
;;(format #t "Stream ~a\n" text)
(make-stream stream-next 0))
;; silly table functions
(define (tbl-column-count tbl)
(length (car tbl)))
(define (tbl-row-count tbl)
(length tbl))
(define (tbl-ref tbl row-index column-index)
(list-ref (list-ref tbl row-index) column-index))
(define (tbl-ref->number tbl row-index column-index)
(string->number (car (tbl-ref tbl row-index column-index))))
;;
;; Test sinks
;;
(define (make-test-sink) (list 'sink 0 '()))
(define (test-sink-count sink)
(second sink))
(define (test-sink-count! sink value)
(set-car! (cdr sink) value))
(define (test-sink-messages sink)
(third sink))
(define (test-sink-messages! sink messages)
(set-car! (cdr (cdr sink)) messages))
(define (test-sink-check sink message flag)
(test-sink-count! sink (+ (test-sink-count sink) 1))
(if flag #t
(test-sink-messages! sink (cons message (test-sink-messages sink)))))
(define (test-sink-report sink)
(format #t "Completed ~a tests ~a\n"
(test-sink-count sink)
(if (null? (test-sink-messages sink)) "PASS" "FAIL"))
(if (null? (test-sink-messages sink)) #t
(begin (for-each (lambda (delayed-message)
(delayed-format-render #t delayed-message))
(test-sink-messages sink))
#f)))
(define (delayed-format . x) x)
(define (delayed-format-render stream msg)
(apply format stream msg))
;;
;; options
;;
(define (create-option-set)
(make-hash-table) )
(define (option-set-setter option-set)
(lambda (category name value)
(hash-set! option-set (list category name) value)))
(define (option-set-getter option-set)
(lambda (category name)
(hash-ref option-set (list category name))))
;;
;;
;;
(define (report-show-options stream expense-options)
(gnc:options-for-each (lambda (option)
(format stream "Option: ~a.~a Value ~a\n"
(gnc:option-section option)
(gnc:option-name option)
(gnc:option-value option)))
expense-options))

20
src/report/report-system/test/test-list-extras.scm Normal file
View File

@@ -0,0 +1,20 @@
(use-modules (gnucash report report-system list-extras))
(use-modules (gnucash report report-system test test-extras))
(define (run-test)
(test test-list-min-max))
(define (test-list-min-max)
(and (equal? (cons 1 1) (list-min-max (list 1) <))
(equal? (cons 1 2) (list-min-max (list 1 2) <))
(equal? (cons 1 2) (list-min-max (list 2 1) <))
(equal? (cons 1 2) (list-min-max (list 1 1 2) <))
(equal? (cons 1 2) (list-min-max (list 1 2 1) <))
(equal? (cons 1 2) (list-min-max (list 1 2 2) <))
(equal? (cons 1 2) (list-min-max (list 2 1 1) <))
(equal? (cons 1 2) (list-min-max (list 2 2 1) <))
(equal? (cons 1 3) (list-min-max (list 1 1 3) <))
(equal? (cons 1 3) (list-min-max (list 1 2 3) <))
(equal? (cons 1 3) (list-min-max (list 1 3 2) <))
(equal? (cons 1 3) (list-min-max (list 2 3 1) <))
(equal? (cons 1 3) (list-min-max (list 3 2 1) <))))

98
src/report/report-system/test/test-test-extras.scm Normal file
View File

@@ -0,0 +1,98 @@
(use-modules (gnucash report report-system test test-extras))
(use-modules (ice-9 streams))
(define (run-test)
(and (logging-and #t)
(logging-and)
(not (logging-and #t #f))
(test-pattern-streamer)
(test-create-account-structure)))
(define (test-pattern-streamer)
(and (test test-pattern-streamer-1)
(test test-pattern-streamer-2)
(test test-pattern-streamer-3)
(test test-pattern-streamer-4)
#t))
(define (test-pattern-streamer-1)
(let* ((content (values-for-text "tbl row x 1 y 2 row x 3 y 4 ")))
(format #t "Values: ~a ~a\n" content (list (list 1 2) (list 3 4)))
(equal? '((("1") ("2")) (("3") ("4"))) content)))
(define (test-pattern-streamer-2)
(let* ((text "")
(content (values-for-text text)))
(format #t "Values: ~a\n" content)
(equal? (list) content)))
(define (values-for-text text)
(let* ((content-stream (pattern-streamer "row" (list (list "x ([0-9]*) " 1)
(list "y ([0-9]*) " 1))
text))
(content (stream->list content-stream)))
content))
(define (test-pattern-streamer-4)
(let* ((text "tbl row x 11 v 12 v 13 row x 21 v 22 v 23 ")
(content-stream (pattern-streamer "row"
(list (list "x ([0-9]*) " 1)
(list "v ([0-9]*) " 1)
(list "v ([0-9]*) " 1))
text))
(content (stream->list content-stream)))
(= 11 (tbl-ref->number content 0 0))
(= 23 (tbl-ref->number content 1 2))))
(define stuff "<table>
<tr>
<th><string> Date</th>
<th><string> Auto</th>
<th><string> Groceries</th>
<th><string> Rent</th>
<th><string> Expenses</th>
<th><string> Grand Total</th>
</tr>
")
(define (test-pattern-streamer-3)
(let ((columns (stream->list (pattern-streamer "<th>"
(list (list "<string> ([^<]*)</" 1))
stuff))))
(format #t "columns ~a\n" columns)
(= 6 (length columns))))
;;
;;
;;
;(use-modules (gnucash engine))
;(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
;(use-modules (gnucash printf))
;(use-modules (gnucash report report-system))
;(use-modules (gnucash app-utils))
;(use-modules (gnucash engine))
(use-modules (sw_engine))
(define (test-create-account-structure)
(let ((env (create-test-env)))
(let ((accounts (env-create-account-structure env (list "Assets"
(list (cons 'type ACCT-TYPE-ASSET))
(list "Bank Account")
(list "Savings"
(list "Instant")
(list "30 day notice"))))))
(format #t "Accounts ~a\n" accounts)
(and (= 3 (length accounts))
(equal? "Assets" (xaccAccountGetName (car accounts)))
))))