Browse Source

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.
gn-latest-20200428
Ludovic Courtès 9 years ago
parent
commit
ba326ce41b
  1. 35
      distro.scm
  2. 8
      tests/packages.scm

35
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)))))
(append-map (lambda (module)
(filter right-package?
(module-map (lambda (sym var)
(variable-ref var))
module)))
(package-modules)))
(string=? (package-name p) name))))
(fold-packages (lambda (package result)
(if (right-package? package)
(cons package result)
result))
'()))

8
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:
Loading…
Cancel
Save