r23021 - gnucash/trunk/src/report/report-system - Add some plumbing for report changes - test framework plus some utility methods
Geert Janssens
gjanssens at code.gnucash.org
Sun Jun 2 06:31:26 EDT 2013
Author: gjanssens
Date: 2013-06-02 06:31:26 -0400 (Sun, 02 Jun 2013)
New Revision: 23021
Trac: http://svn.gnucash.org/trac/changeset/23021
Added:
gnucash/trunk/src/report/report-system/collectors.scm
gnucash/trunk/src/report/report-system/list-extras.scm
gnucash/trunk/src/report/report-system/test/test-collectors.scm
gnucash/trunk/src/report/report-system/test/test-extras.scm
gnucash/trunk/src/report/report-system/test/test-list-extras.scm
gnucash/trunk/src/report/report-system/test/test-test-extras.scm
Modified:
gnucash/trunk/src/report/report-system/Makefile.am
gnucash/trunk/src/report/report-system/test/Makefile.am
Log:
Add some plumbing for report changes - test framework plus some utility methods
Author: Peter Broadbery <p.broadbery at gmail.com>
Modified: gnucash/trunk/src/report/report-system/Makefile.am
===================================================================
--- gnucash/trunk/src/report/report-system/Makefile.am 2013-06-02 10:31:13 UTC (rev 23020)
+++ gnucash/trunk/src/report/report-system/Makefile.am 2013-06-02 10:31:26 UTC (rev 23021)
@@ -54,10 +54,17 @@
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 @@
# 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
Added: gnucash/trunk/src/report/report-system/collectors.scm
===================================================================
--- gnucash/trunk/src/report/report-system/collectors.scm (rev 0)
+++ gnucash/trunk/src/report/report-system/collectors.scm 2013-06-02 10:31:26 UTC (rev 23021)
@@ -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))))
Added: gnucash/trunk/src/report/report-system/list-extras.scm
===================================================================
--- gnucash/trunk/src/report/report-system/list-extras.scm (rev 0)
+++ gnucash/trunk/src/report/report-system/list-extras.scm 2013-06-02 10:31:26 UTC (rev 23021)
@@ -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))))
Modified: gnucash/trunk/src/report/report-system/test/Makefile.am
===================================================================
--- gnucash/trunk/src/report/report-system/test/Makefile.am 2013-06-02 10:31:13 UTC (rev 23020)
+++ gnucash/trunk/src/report/report-system/test/Makefile.am 2013-06-02 10:31:26 UTC (rev 23021)
@@ -15,13 +15,20 @@
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 @@
--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 @@
--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 @@
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}
Added: gnucash/trunk/src/report/report-system/test/test-collectors.scm
===================================================================
--- gnucash/trunk/src/report/report-system/test/test-collectors.scm (rev 0)
+++ gnucash/trunk/src/report/report-system/test/test-collectors.scm 2013-06-02 10:31:26 UTC (rev 23021)
@@ -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))))
Added: gnucash/trunk/src/report/report-system/test/test-extras.scm
===================================================================
--- gnucash/trunk/src/report/report-system/test/test-extras.scm (rev 0)
+++ gnucash/trunk/src/report/report-system/test/test-extras.scm 2013-06-02 10:31:26 UTC (rev 23021)
@@ -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))
+
Added: gnucash/trunk/src/report/report-system/test/test-list-extras.scm
===================================================================
--- gnucash/trunk/src/report/report-system/test/test-list-extras.scm (rev 0)
+++ gnucash/trunk/src/report/report-system/test/test-list-extras.scm 2013-06-02 10:31:26 UTC (rev 23021)
@@ -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) <))))
Added: gnucash/trunk/src/report/report-system/test/test-test-extras.scm
===================================================================
--- gnucash/trunk/src/report/report-system/test/test-test-extras.scm (rev 0)
+++ gnucash/trunk/src/report/report-system/test/test-test-extras.scm 2013-06-02 10:31:26 UTC (rev 23021)
@@ -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)))
+ ))))
+
+
+
+
More information about the gnucash-changes
mailing list