diff options
| -rw-r--r-- | guix/packages.scm | 25 | ||||
| -rw-r--r-- | tests/packages.scm | 23 |
2 files changed, 47 insertions, 1 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index e4c2ac3be5..f191327718 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> @@ -133,6 +133,7 @@ bag-transitive-host-inputs bag-transitive-build-inputs bag-transitive-target-inputs + package-closure default-guile default-guile-derivation @@ -798,6 +799,28 @@ dependencies are known to build on SYSTEM." "Return the \"target inputs\" of BAG, recursively." (transitive-inputs (bag-target-inputs bag))) +(define* (package-closure packages #:key (system (%current-system))) + "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of +packages they depend on, recursively." + (let loop ((packages packages) + (visited vlist-null) + (closure (list->setq packages))) + (match packages + (() + (set->list closure)) + ((package . rest) + (if (vhash-assq package visited) + (loop rest visited closure) + (let* ((bag (package->bag package system)) + (dependencies (filter-map (match-lambda + ((label (? package? package) . _) + package) + (_ #f)) + (bag-direct-inputs bag)))) + (loop (append dependencies rest) + (vhash-consq package #t visited) + (fold set-insert closure dependencies)))))))) + (define* (package-mapping proc #:optional (cut? (const #f))) "Return a procedure that, given a package, applies PROC to all the packages depended on and returns the resulting package. The procedure stops recursion diff --git a/tests/packages.scm b/tests/packages.scm index 29e5e4103c..e5704ae4b9 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -249,6 +249,28 @@ (package-transitive-supported-systems d) (package-transitive-supported-systems e)))) +(test-assert "package-closure" + (let-syntax ((dummy-package/no-implicit + (syntax-rules () + ((_ name rest ...) + (package + (inherit (dummy-package name rest ...)) + (build-system trivial-build-system)))))) + (let* ((a (dummy-package/no-implicit "a")) + (b (dummy-package/no-implicit "b" + (propagated-inputs `(("a" ,a))))) + (c (dummy-package/no-implicit "c" + (inputs `(("a" ,a))))) + (d (dummy-package/no-implicit "d" + (native-inputs `(("b" ,b))))) + (e (dummy-package/no-implicit "e" + (inputs `(("c" ,c) ("d" ,d)))))) + (lset= eq? + (list a b c d e) + (package-closure (list e)) + (package-closure (list e d)) + (package-closure (list e c b)))))) + (test-equal "origin-actual-file-name" "foo-1.tar.gz" (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz")))) @@ -1180,4 +1202,5 @@ ;;; Local Variables: ;;; eval: (put 'dummy-package 'scheme-indent-function 1) +;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1) ;;; End: |