From ba326ce41b5784f3acb99d4beae5ffc455d6a27e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 19 Nov 2012 22:37:50 +0100
Subject: [PATCH] distro: Add `fold-packages'.

* distro.scm (fold-packages): New procedure.
  (find-packages-by-name): Use it instead of hand-written traversal;
  remove `package?' checks from `right-package?'.
* tests/packages.scm ("fold-packages"): New test.
---
 distro.scm         | 33 +++++++++++++++++++++++----------
 tests/packages.scm |  8 ++++++++
 2 files changed, 31 insertions(+), 10 deletions(-)

diff --git a/distro.scm b/distro.scm
index bbfe51c943..2d441f450b 100644
--- a/distro.scm
+++ b/distro.scm
@@ -26,6 +26,7 @@
   #:export (search-patch
             search-bootstrap-binary
             %patch-directory
+            fold-packages
             find-packages-by-name))
 
 ;;; Commentary:
@@ -105,22 +106,34 @@
                   (false-if-exception (resolve-interface name))))
               (package-files)))
 
+(define (fold-packages proc init)
+  "Call (PROC PACKAGE RESULT) for each available package, using INIT as
+the initial value of RESULT."
+  (fold (lambda (module result)
+          (fold (lambda (var result)
+                  (if (package? var)
+                      (proc var result)
+                      result))
+                result
+                (module-map (lambda (sym var)
+                              (false-if-exception (variable-ref var)))
+                            module)))
+        init
+        (package-modules)))
+
 (define* (find-packages-by-name name #:optional version)
   "Return the list of packages with the given NAME.  If VERSION is not #f,
 then only return packages whose version is equal to VERSION."
   (define right-package?
     (if version
         (lambda (p)
-          (and (package? p)
-               (string=? (package-name p) name)
+          (and (string=? (package-name p) name)
                (string=? (package-version p) version)))
         (lambda (p)
-          (and (package? p)
-               (string=? (package-name p) name)))))
+          (string=? (package-name p) name))))
 
-  (append-map (lambda (module)
-                (filter right-package?
-                        (module-map (lambda (sym var)
-                                      (variable-ref var))
-                                    module)))
-              (package-modules)))
+  (fold-packages (lambda (package result)
+                   (if (right-package? package)
+                       (cons package result)
+                       result))
+                 '()))
diff --git a/tests/packages.scm b/tests/packages.scm
index 29ea691e9f..cb69e4be4e 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -120,6 +120,13 @@
            (and (build-derivations %store (list drv))
                 (file-exists? (string-append out "/bin/make")))))))
 
+(test-eq "fold-packages" hello
+  (fold-packages (lambda (p r)
+                   (if (string=? (package-name p) "hello")
+                       p
+                       r))
+                 #f))
+
 (test-assert "find-packages-by-name"
   (match (find-packages-by-name "hello")
     (((? (cut eq? hello <>))) #t)
@@ -136,6 +143,7 @@
 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 
 ;;; Local Variables:
+;;; eval: (put 'test-equal 'scheme-indent-function 2)
 ;;; eval: (put 'test-assert 'scheme-indent-function 1)
 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 ;;; End: