fix compose in srfi-171 and add generator-transduce

%3a171.sls

@@ -1,6 +1,6 @@
 (library (srfi :171)
   (export rcons reverse-rcons rcount rany revery
-          list-transduce vector-transduce string-transduce bytevector-u8-transduce port-transduce
+          list-transduce vector-transduce string-transduce bytevector-u8-transduce port-transduce generator-transduce
           compose
           tmap tfilter tremove treplace tfilter-map tdrop tdrop-while ttake ttake-while
           tconcatenate tappend-map tdelete-neighbor-dupes tdelete-duplicates tflatten

%3a171/meta.sls

@@ -14,7 +14,7 @@
 
 (library (srfi :171 meta)
   (export reduced reduced? unreduce ensure-reduced preserving-reduced
-          list-reduce vector-reduce string-reduce bytevector-u8-reduce port-reduce)
+          list-reduce vector-reduce string-reduce bytevector-u8-reduce port-reduce generator-reduce)
   (import (except (rnrs) define-record-type)
           (srfi :9 records))
 
@@ -87,4 +87,13 @@
           (let ((acc (f acc val)))
             (if (reduced? acc)
                 (unreduce acc)
-                (loop (reader port) acc)))))))
+                (loop (reader port) acc))))))
+
+  (define (generator-reduce f identity gen)
+    (let loop ((val (gen)) (acc identity))
+      (if (eof-object? val)
+          acc
+          (let ((acc (f acc val)))
+            (if (reduced? acc)
+                (unreduce acc)
+                (loop (gen) acc)))))))

%3a171/transducers.sls

@@ -14,7 +14,7 @@
 
 (library (srfi :171 transducers)
   (export rcons reverse-rcons rcount rany revery
-          list-transduce vector-transduce string-transduce bytevector-u8-transduce port-transduce
+          list-transduce vector-transduce string-transduce bytevector-u8-transduce port-transduce generator-transduce
           compose
           tmap tfilter tremove treplace tfilter-map tdrop tdrop-while ttake ttake-while
           tconcatenate tappend-map tdelete-neighbor-dupes tdelete-duplicates tflatten
@@ -130,14 +130,22 @@
        (let* ((xf (xform f))
               (result (port-reduce xf init by port)))
          (xf result)))))
-
-  ;; compose unary functions
-  (define compose
+
+  (define generator-transduce
     (case-lambda
-      (() (lambda (x) x))
-      ((f) f)
-      ((f g) (lambda (x) (f (g x))))
-      ((f . gs) (reduce compose f gs))))
+      ((xform f gen)
+       (generator-transduce xform f (f) gen))
+      ((xform f init gen)
+       (let* ((xf (xform f))
+              (result (generator-reduce xf init gen)))
+         (xf result)))))
+
+  ;; compose unary functions
+  (define (compose . fns)
+    (define (make-chain fn chain)
+      (lambda args
+        (call-with-values (lambda () (apply fn args)) chain)))
+    (reduce make-chain values fns))
 
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; Transducers!    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

tests/transducers.sps

@@ -1,10 +1,11 @@
 #!r6rs
 
 (import
-  (rnrs)
-  (only (srfi :1) iota)
-  (srfi :64 testing)
-  (srfi :171 transducers))
+ (rnrs)
+ (only (srfi :1) iota)
+ (srfi :64 testing)
+ (srfi :171 transducers)
+ (srfi :158 generators-and-accumulators))
 
 (define (add1 x) (+ x 1))
 
@@ -18,6 +19,7 @@
 (test-equal '(1 2 3 4 5) (list-transduce (tmap add1) rcons numeric-list))
 (test-equal '(0 2 4) (list-transduce (tfilter even?) rcons numeric-list))
 (test-equal '(1 3 5) (list-transduce (compose (tfilter even?) (tmap add1)) rcons numeric-list))
+(test-equal '(2 4 6) (list-transduce (compose (tfilter even?) (tmap add1) (tmap add1)) rcons numeric-list))
 
 (test-equal (string-transduce (tmap char->integer) rcons example-string) (list-transduce (tmap char->integer) rcons list-of-chars))
 (test-equal 6 (string-transduce (tfilter char-alphabetic?) rcount example-string))
@@ -49,5 +51,7 @@
 
 (test-equal '((-1 . 0) (0 . 1) (1 . 2) (2 . 3) (3 . 4)) (list-transduce (tenumerate (- 1)) rcons numeric-list))
 
+(test-equal '(1 3 5) (generator-transduce (compose (tfilter even?) (tmap add1)) rcons (make-range-generator 0 5)))
+
 (test-end "transducers")