From 03a70e4c190420e87c0b535285caf8f77260d4ff Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 11 Jun 2020 18:24:59 +0200
Subject: packages: 'package-grafts' returns grafts for all the relevant
 outputs.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Fixes <https://bugs.gnu.org/41796>.
Reported by Jakub Kądziołka <kuba@kadziolka.net>.

* guix/packages.scm (input-graft): Add 'output' parameter and honor it.
Add OUTPUT to the cache key.
(input-cross-graft): Likewise.
(fold-bag-dependencies): Operate on inputs instead of nodes.  Turn
VISITED into a vhash instead of a set.  Pass PROC HEAD and OUTPUT
instead of just HEAD.
(bag-grafts): Adjust accordingly.
* tests/packages.scm ("package-grafts, dependency on several outputs"):
New test.
---
 guix/packages.scm | 81 ++++++++++++++++++++++++++-----------------------------
 1 file changed, 38 insertions(+), 43 deletions(-)

(limited to 'guix/packages.scm')

diff --git a/guix/packages.scm b/guix/packages.scm
index 0ccd31a7a9..1e0ec41b76 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1194,39 +1194,39 @@ and return it."
   (make-weak-key-hash-table 200))
 
 (define (input-graft store system)
-  "Return a procedure that, given a package with a graft, returns a graft, and
-#f otherwise."
-  (match-lambda
-    ((? package? package)
+  "Return a procedure that, given a package with a replacement and an output name,
+returns a graft, and #f otherwise."
+  (match-lambda*
+    (((? package? package) output)
      (let ((replacement (package-replacement package)))
        (and replacement
-            (cached (=> %graft-cache) package system
+            (cached (=> %graft-cache) package (cons output system)
                     (let ((orig (package-derivation store package system
                                                     #:graft? #f))
                           (new  (package-derivation store replacement system
                                                     #:graft? #t)))
                       (graft
                         (origin orig)
-                        (replacement new)))))))
-    (x
-     #f)))
+                        (origin-output output)
+                        (replacement new)
+                        (replacement-output output)))))))))
 
 (define (input-cross-graft store target system)
   "Same as 'input-graft', but for cross-compilation inputs."
-  (match-lambda
-    ((? package? package)
-    (let ((replacement (package-replacement package)))
-      (and replacement
-           (let ((orig (package-cross-derivation store package target system
-                                                 #:graft? #f))
-                 (new  (package-cross-derivation store replacement
-                                                 target system
-                                                 #:graft? #t)))
-             (graft
-               (origin orig)
-               (replacement new))))))
-   (_
-    #f)))
+  (match-lambda*
+    (((? package? package) output)
+     (let ((replacement (package-replacement package)))
+       (and replacement
+            (let ((orig (package-cross-derivation store package target system
+                                                  #:graft? #f))
+                  (new  (package-cross-derivation store replacement
+                                                  target system
+                                                  #:graft? #t)))
+              (graft
+                (origin orig)
+                (origin-output output)
+                (replacement new)
+                (replacement-output output))))))))
 
 (define* (fold-bag-dependencies proc seed bag
                                 #:key (native? #t))
@@ -1243,26 +1243,21 @@ dependencies; otherwise, restrict to target dependencies."
                       (bag-host-inputs bag))))
         bag-host-inputs))
 
-  (define nodes
-    (match (bag-direct-inputs* bag)
-      (((labels things _ ...) ...)
-       things)))
-
-  (let loop ((nodes nodes)
+  (let loop ((inputs (bag-direct-inputs* bag))
              (result seed)
-             (visited (setq)))
-    (match nodes
+             (visited vlist-null))
+    (match inputs
       (()
        result)
-      (((? package? head) . tail)
-       (if (set-contains? visited head)
-           (loop tail result visited)
-           (let ((inputs (bag-direct-inputs* (package->bag head))))
-             (loop (match inputs
-                     (((labels things _ ...) ...)
-                      (append things tail)))
-                   (proc head result)
-                   (set-insert head visited)))))
+      (((label (? package? head) . rest) . tail)
+       (let ((output  (match rest (() "out") ((output) output)))
+             (outputs (vhash-foldq* cons '() head visited)))
+         (if (member output outputs)
+             (loop tail result visited)
+             (let ((inputs (bag-direct-inputs* (package->bag head))))
+               (loop (append inputs tail)
+                     (proc head output result)
+                     (vhash-consq head output visited))))))
       ((head . tail)
        (loop tail result visited)))))
 
@@ -1279,8 +1274,8 @@ to (see 'graft-derivation'.)"
     (let ((->graft (input-graft store system)))
       (parameterize ((%current-system system)
                      (%current-target-system #f))
-        (fold-bag-dependencies (lambda (package grafts)
-                                 (match (->graft package)
+        (fold-bag-dependencies (lambda (package output grafts)
+                                 (match (->graft package output)
                                    (#f    grafts)
                                    (graft (cons graft grafts))))
                                '()
@@ -1291,8 +1286,8 @@ to (see 'graft-derivation'.)"
         (let ((->graft (input-cross-graft store target system)))
           (parameterize ((%current-system system)
                          (%current-target-system target))
-            (fold-bag-dependencies (lambda (package grafts)
-                                     (match (->graft package)
+            (fold-bag-dependencies (lambda (package output grafts)
+                                     (match (->graft package output)
                                        (#f    grafts)
                                        (graft (cons graft grafts))))
                                    '()
-- 
cgit v1.2.3