futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

packages: Add 'package-closure'.

Browse Source 
* guix/packages.scm (package-closure): New procedure.
* tests/packages.scm ("package-closure"): New test.
This commit is contained in:
Ludovic Courtès 2019-01-25 10:05:31 +01:00
parent c6e33df90f
commit 3e223a22a7
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 47 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
guix/packages.scm
View File

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

23
tests/packages.scm
View File

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