01/02: packages: 'package-grafts' returns grafts for all the relevant outputs.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 03a70e4c190420e87c0b535285caf8f77260d4ff
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Jun 11 18:24:59 2020 +0200

    packages: 'package-grafts' returns grafts for all the relevant outputs.
    
    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 +++++++++++++++++++++++++-----------------------------
 tests/packages.scm | 24 ++++++++++++++++
 2 files changed, 62 insertions(+), 43 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 0ccd31a..1e0ec41 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))))
                                    '()
diff --git a/tests/packages.scm b/tests/packages.scm
index 72e87db..c7b6f66 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -900,6 +900,30 @@
                                                          (replacement #f))))
                     (replacement (package-derivation %store new)))))))
 
+(test-assert "package-grafts, dependency on several outputs"
+  ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
+  (letrec* ((p0  (dummy-package "p0"
+                   (version "1.0")
+                   (replacement p0*)
+                   (arguments '(#:implicit-inputs? #f))
+                   (outputs '("out" "lib"))))
+            (p0* (package (inherit p0) (version "1.1")))
+            (p1  (dummy-package "p1"
+                   (arguments '(#:implicit-inputs? #f))
+                   (inputs `(("p0" ,p0)
+                             ("p0:lib" ,p0 "lib"))))))
+    (lset= equal? (pk (package-grafts %store p1))
+           (list (graft
+                   (origin (package-derivation %store p0))
+                   (origin-output "out")
+                   (replacement (package-derivation %store p0*))
+                   (replacement-output "out"))
+                 (graft
+                   (origin (package-derivation %store p0))
+                   (origin-output "lib")
+                   (replacement (package-derivation %store p0*))
+                   (replacement-output "lib"))))))
+
 (test-assert "replacement also grafted"
   ;; We build a DAG as below, where dotted arrows represent replacements and
   ;; solid arrows represent dependencies: