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.
This commit is contained in:
Ludovic Courtès 2012-11-19 22:37:50 +01:00
parent 733b4130d7
commit ba326ce41b
2 changed files with 31 additions and 10 deletions

View File

@ -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))
'()))

View File

@ -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: