summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-14 16:56:08 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-14 16:56:08 +0200
commit04fd96cac33fa7557e574e54575252564ba27111 (patch)
tree42f0ca2251cf6effb82b9d38f7789e2ad54842a8
parent77ffd691bfbb152cde94b60aa8df5135d39727c3 (diff)
downloadpatches-04fd96cac33fa7557e574e54575252564ba27111.tar
patches-04fd96cac33fa7557e574e54575252564ba27111.tar.gz
utils: Add `fold2'.
* gnu/packages.scm (fold2): Remove. * guix/utils.scm (fold2): New procedure. Generalization of the above to one and two lists. * tests/utils.scm ("fold2, 1 list", "fold2, 2 lists"): New tests.
-rw-r--r--gnu/packages.scm8
-rw-r--r--guix/utils.scm29
-rw-r--r--tests/utils.scm25
3 files changed, 53 insertions, 9 deletions
diff --git a/gnu/packages.scm b/gnu/packages.scm
index b639541788..f4d93a789d 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -110,14 +110,6 @@
(false-if-exception (resolve-interface name))))
(package-files)))
-(define (fold2 f seed1 seed2 lst)
- (if (null? lst)
- (values seed1 seed2)
- (call-with-values
- (lambda () (f (car lst) seed1 seed2))
- (lambda (seed1 seed2)
- (fold2 f seed1 seed2 (cdr lst))))))
-
(define (fold-packages proc init)
"Call (PROC PACKAGE RESULT) for each available package, using INIT as
the initial value of RESULT. It is guaranteed to never traverse the
diff --git a/guix/utils.scm b/guix/utils.scm
index d7c37e37d1..f13e585e2b 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -59,7 +59,8 @@
%current-system
version-compare
version>?
- package-name->name+version))
+ package-name->name+version
+ fold2))
;;;
@@ -463,6 +464,32 @@ introduce the version part."
((head tail ...)
(loop tail (cons head prefix))))))
+(define fold2
+ (case-lambda
+ ((proc seed1 seed2 lst)
+ "Like `fold', but with a single list and two seeds."
+ (let loop ((result1 seed1)
+ (result2 seed2)
+ (lst lst))
+ (if (null? lst)
+ (values result1 result2)
+ (call-with-values
+ (lambda () (proc (car lst) result1 result2))
+ (lambda (result1 result2)
+ (loop result1 result2 (cdr lst)))))))
+ ((proc seed1 seed2 lst1 lst2)
+ "Like `fold', but with a two lists and two seeds."
+ (let loop ((result1 seed1)
+ (result2 seed2)
+ (lst1 lst1)
+ (lst2 lst2))
+ (if (or (null? lst1) (null? lst2))
+ (values result1 result2)
+ (call-with-values
+ (lambda () (proc (car lst1) (car lst2) result1 result2))
+ (lambda (result1 result2)
+ (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
+
;;;
;;; Source location.
diff --git a/tests/utils.scm b/tests/utils.scm
index bcdd120a74..fa7d7b03fd 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -64,6 +64,31 @@
("nixpkgs" "1.0pre22125_a28fe19")
("gtk2" "2.38.0"))))
+(test-equal "fold2, 1 list"
+ (list (reverse (iota 5))
+ (map - (reverse (iota 5))))
+ (call-with-values
+ (lambda ()
+ (fold2 (lambda (i r1 r2)
+ (values (cons i r1)
+ (cons (- i) r2)))
+ '() '()
+ (iota 5)))
+ list))
+
+(test-equal "fold2, 2 lists"
+ (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
+ (reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
+ (call-with-values
+ (lambda ()
+ (fold2 (lambda (k v r1 r2)
+ (values (alist-cons k v r1)
+ (alist-cons k (- v) r2)))
+ '() '()
+ '(a b c d)
+ '(0 1 2 3)))
+ list))
+
(test-assert "define-record-type*"
(begin
(define-record-type* <foo> foo make-foo