r23023 - gnucash/trunk/src/report/report-system - Reports: Add collector functionality for side effects..

[Geert Janssens]

Author: gjanssens
Date: 2013-06-02 06:31:51 -0400 (Sun, 02 Jun 2013)
New Revision: 23023
Trac: http://svn.gnucash.org/trac/changeset/23023

Modified:
   gnucash/trunk/src/report/report-system/collectors.scm
   gnucash/trunk/src/report/report-system/test/test-collectors.scm
Log:
Reports: Add collector functionality for side effects..
function-state->collector; turn a function/initial state into a collector
collector-do: Like collector-map, but only return the result of the first collector.
	It's assumed the other collectors are invoked for their side effects.

Author:    Peter Broadbery <p.broadbery at gmail.com>

Modified: gnucash/trunk/src/report/report-system/collectors.scm
===================================================================
--- gnucash/trunk/src/report/report-system/collectors.scm	2013-06-02 10:31:39 UTC (rev 23022)
+++ gnucash/trunk/src/report/report-system/collectors.scm	2013-06-02 10:31:51 UTC (rev 23023)
@@ -26,7 +26,8 @@
 (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)
 
@@ -300,6 +301,19 @@
 						  (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))))
+
 ;;
 ;; Predicates
 ;;

Modified: gnucash/trunk/src/report/report-system/test/test-collectors.scm
===================================================================
--- gnucash/trunk/src/report/report-system/test/test-collectors.scm	2013-06-02 10:31:39 UTC (rev 23022)
+++ gnucash/trunk/src/report/report-system/test/test-collectors.scm	2013-06-02 10:31:51 UTC (rev 23023)
@@ -16,6 +16,8 @@
        (test test-collector-from-slotset)
        (test test-binary-search-lt)
        (test test-collector-into-list)
+       (test test-function-state->collector)
+       (test test-collector-do)
        #t))
 
 
@@ -177,3 +179,24 @@
 					     (stream-range 0 (+ (* (vector-length vector) 2) 1))))
 					  vectors)))
 	 (stream-for-each (lambda (x) x) tested-vectors))))
+
+(define (test-function-state->collector)
+  (define (count v current-count) (+ current-count 1))
+  (define (check-count l)
+    (= (length l) (collector-add-all (function-state->collector count 0) l)))
+  (check-count '())
+  (check-count '(1))
+  (check-count '(1 2 3)))
+
+(define (test-collector-do)
+  (let ((count 0))
+    (let ((add-to-list-and-count (collector-do (collector-into-list)
+					       (function-state->collector (lambda (v n)
+									    (set! count (+ n 1))
+									    (+ n 1))
+									  0))))
+      (let* ((orig '(one two three))
+	     (collected (collector-add-all add-to-list-and-count orig)))
+	(format #t "~a ~a ~a\n" count collected orig)
+	(and (equal? orig collected)
+	     (= count (length orig)))))))