me/guix
Archived
1
0
Fork 0
Code Activity

packages: 'package-transitive-supported-systems' accounts for indirect deps.

Browse source 
Reported by Andreas Enge <andreas@enge.fr>.

* guix/packages.scm (first-value): New macro.
  (package-transitive-supported-systems): Rewrite to traverse all the
  DAG rooted at PACKAGE.
* tests/packages.scm ("package-transitive-supported-systems"): Add 'd'
  and 'e', and test them.
This commit is contained in:
Ludovic Courtès 2014-11-03 21:26:48 +01:00
parent 6888830b35
commit c37a74bd3e
2 changed files with 45 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
guix/packages.scm
View file

@ -24,6 +24,7 @@
#:use-module (guix derivations)
#:use-module (guix build-system)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
@ -542,16 +543,40 @@ for the host system (\"native inputs\"), and not target inputs."
recursively."
(transitive-inputs (package-propagated-inputs package)))
(define-syntax-rule (first-value exp)
"Truncate all but the first value returned by EXP."
(call-with-values (lambda () exp)
(lambda (result . _)
result)))
(define (package-transitive-supported-systems package)
"Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
(apply lset-intersection string=?
(package-supported-systems package)
(filter-map (match-lambda
((label (? package? p) . rest)
(package-supported-systems p))
(_ #f))
(package-transitive-inputs package))))
(first-value
(let loop ((package package)
(systems (package-supported-systems package))
(visited vlist-null))
(match (vhash-assq package visited)
((_ . result)
(values (lset-intersection string=? systems result)
visited))
(#f
(call-with-values
(lambda ()
(fold2 (lambda (input systems visited)
(match input
((label (? package? package) . _)
(loop package systems visited))
(_
(values systems visited))))
(lset-intersection string=?
systems
(package-supported-systems package))
visited
(package-direct-inputs package)))
(lambda (systems visited)
(values systems
(vhash-consq package systems visited)))))))))
(define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag."

18
tests/packages.scm
View file

@ -125,17 +125,25 @@
(pk 'x (package-transitive-inputs e))))))
(test-equal "package-transitive-supported-systems"
'(("x" "y" "z")
("x" "y")
("y"))
'(("x" "y" "z") ;a
("x" "y") ;b
("y") ;c
("y") ;d
("y")) ;e
(let* ((a (dummy-package "a" (supported-systems '("x" "y" "z"))))
(b (dummy-package "b" (supported-systems '("x" "y"))
(inputs `(("a" ,a)))))
(c (dummy-package "c" (supported-systems '("y" "z"))
(inputs `(("b" ,b))))))
(inputs `(("b" ,b)))))
(d (dummy-package "d" (supported-systems '("x" "y" "z"))
(inputs `(("b" ,b) ("c" ,c)))))
(e (dummy-package "e" (supported-systems '("x" "y" "z"))
(inputs `(("d" ,d))))))
(list (package-transitive-supported-systems a)
(package-transitive-supported-systems b)
(package-transitive-supported-systems c))))
(package-transitive-supported-systems c)
(package-transitive-supported-systems d)
(package-transitive-supported-systems e))))
(test-skip (if (not %store) 8 0))