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
					
				
					 3 changed files with 53 additions and 9 deletions
				
			
		| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Reference in a new issue