kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases 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 derivations)
#:use-module (guix build-system) #:use-module (guix build-system)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
@ -542,16 +543,40 @@ for the host system (\"native inputs\"), and not target inputs."
recursively." recursively."
(transitive-inputs (package-propagated-inputs package))) (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) (define (package-transitive-supported-systems package)
"Return the intersection of the systems supported by PACKAGE and those "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies." supported by its dependencies."
(apply lset-intersection string=? (first-value
(package-supported-systems package) (let loop ((package package)
(filter-map (match-lambda (systems (package-supported-systems package))
((label (? package? p) . rest) (visited vlist-null))
(package-supported-systems p)) (match (vhash-assq package visited)
(_ #f)) ((_ . result)
(package-transitive-inputs package)))) (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) (define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a 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)))))) (pk 'x (package-transitive-inputs e))))))
(test-equal "package-transitive-supported-systems" (test-equal "package-transitive-supported-systems"
'(("x" "y" "z") '(("x" "y" "z") ;a
("x" "y") ("x" "y") ;b
("y")) ("y") ;c
("y") ;d
("y")) ;e
(let* ((a (dummy-package "a" (supported-systems '("x" "y" "z")))) (let* ((a (dummy-package "a" (supported-systems '("x" "y" "z"))))
(b (dummy-package "b" (supported-systems '("x" "y")) (b (dummy-package "b" (supported-systems '("x" "y"))
(inputs `(("a" ,a))))) (inputs `(("a" ,a)))))
(c (dummy-package "c" (supported-systems '("y" "z")) (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) (list (package-transitive-supported-systems a)
(package-transitive-supported-systems b) (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)) (test-skip (if (not %store) 8 0))