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

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.

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