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.
This commit is contained in:
parent
77ffd691bf
commit
04fd96cac3
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue