diff options
| -rw-r--r-- | guix/packages.scm | 39 | ||||
| -rw-r--r-- | tests/packages.scm | 18 |
2 files changed, 45 insertions, 12 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index 698a4c8097..67a767106e 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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." diff --git a/tests/packages.scm b/tests/packages.scm index 4f700b712f..98fa9b5698 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -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)) |