Merge branch 'master' into core-updates

4 files changed, 65 insertions, 27 deletions

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 53e697688a..80ae27e9b0 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -227,17 +227,33 @@ resulting list of grafts.
 
 This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
 derivations to the corresponding set of grafts."
+  (define (graft-origin? drv graft)
+    ;; Return true if DRV corresponds to the origin of GRAFT.
+    (match graft
+      (($ <graft> (? derivation? origin) output)
+       (match (assoc-ref (derivation->output-paths drv) output)
+         ((? string? result)
+          (string=? result
+                    (derivation->output-path origin output)))
+         (_
+          #f)))
+      (_
+       #f)))
+
   (define (dependency-grafts item)
     (let-values (((drv output) (item->deriver store item)))
       (if drv
-          (cumulative-grafts store drv grafts references
-                             #:outputs (list output)
-                             #:guile guile
-                             #:system system)
+          ;; If GRAFTS already contains a graft from DRV, do not override it.
+          (if (find (cut graft-origin? drv <>) grafts)
+              (state-return grafts)
+              (cumulative-grafts store drv grafts references
+                                 #:outputs (list output)
+                                 #:guile guile
+                                 #:system system))
           (state-return grafts))))
 
   (define (return/cache cache value)
-    (mbegin %store-monad
+    (mbegin %state-monad
       (set-current-state (vhash-consq drv value cache))
       (return value)))
 
@@ -250,10 +266,8 @@ derivations to the corresponding set of grafts."
          (()                                      ;no dependencies
           (return/cache cache grafts))
          (deps                                    ;one or more dependencies
-          (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))
-                              (cache  (current-state)))
-            (let* ((grafts     (delete-duplicates (concatenate grafts) equal?))
-                   (origins    (map graft-origin-file-name grafts)))
+          (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)))
+            (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
               (match (filter (lambda (graft)
                                (member (graft-origin-file-name graft) deps))
                              grafts)
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index e4059ca114..057c2d9c7d 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -26,7 +26,6 @@
   #:use-module (guix utils)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
-  #:use-module (json)
   #:use-module (srfi srfi-1)
   #:export (factorize-uri
 
diff --git a/guix/packages.scm b/guix/packages.scm
index 88b21f709d..beb958f156 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -919,7 +919,8 @@ and return it."
             (cached (=> %graft-cache) package system
                     (let ((orig (package-derivation store package system
                                                     #:graft? #f))
-                          (new  (package-derivation store replacement system)))
+                          (new  (package-derivation store replacement system
+                                                    #:graft? #t)))
                       (graft
                         (origin orig)
                         (replacement new)))))))
@@ -935,7 +936,8 @@ and return it."
            (let ((orig (package-cross-derivation store package target system
                                                  #:graft? #f))
                  (new  (package-cross-derivation store replacement
-                                                 target system)))
+                                                 target system
+                                                 #:graft? #t)))
              (graft
                (origin orig)
                (replacement new))))))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 782fca5d63..2f70d64c90 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -42,6 +42,7 @@
             %bag-emerged-node-type
             %derivation-node-type
             %reference-node-type
+            %referrer-node-type
             %node-types
 
             guix-graph))
@@ -257,6 +258,24 @@ derivation graph")))))))
 ;;; DAG of residual references (aka. run-time dependencies).
 ;;;
 
+(define ensure-store-items
+  ;; Return a list of store items as a monadic value based on the given
+  ;; argument, which may be a store item or a package.
+  (match-lambda
+    ((? package? package)
+     ;; Return the output file names of PACKAGE.
+     (mlet %store-monad ((drv (package->derivation package)))
+       (return (match (derivation->output-paths drv)
+                 (((_ . file-names) ...)
+                  file-names)))))
+    ((? store-path? item)
+     (with-monad %store-monad
+       (return (list item))))
+    (x
+     (raise
+      (condition (&message (message "unsupported argument for \
+this type of graph")))))))
+
 (define (references* item)
   "Return as a monadic value the references of ITEM, based either on the
 information available in the local store or using information about
@@ -275,24 +294,27 @@ substitutes."
   (node-type
    (name "references")
    (description "the DAG of run-time dependencies (store references)")
-   (convert (match-lambda
-              ((? package? package)
-               ;; Return the output file names of PACKAGE.
-               (mlet %store-monad ((drv (package->derivation package)))
-                 (return (match (derivation->output-paths drv)
-                           (((_ . file-names) ...)
-                            file-names)))))
-              ((? store-path? item)
-               (with-monad %store-monad
-                 (return (list item))))
-              (x
-               (raise
-                (condition (&message (message "unsupported argument for \
-reference graph")))))))
+   (convert ensure-store-items)
    (identifier (lift1 identity %store-monad))
    (label store-path-package-name)
    (edges references*)))
 
+(define non-derivation-referrers
+  (let ((referrers (store-lift referrers)))
+    (lambda (item)
+      "Return the referrers of ITEM, except '.drv' files."
+      (mlet %store-monad ((items (referrers item)))
+        (return (remove derivation-path? items))))))
+
+(define %referrer-node-type
+  (node-type
+   (name "referrers")
+   (description "the DAG of referrers in the store")
+   (convert ensure-store-items)
+   (identifier (lift1 identity %store-monad))
+   (label store-path-package-name)
+   (edges non-derivation-referrers)))
+
 
 ;;;
 ;;; List of node types.
@@ -305,7 +327,8 @@ reference graph")))))))
         %bag-with-origins-node-type
         %bag-emerged-node-type
         %derivation-node-type
-        %reference-node-type))
+        %reference-node-type
+        %referrer-node-type))
 
 (define (lookup-node-type name)
   "Return the node type called NAME.  Raise an error if it is not found."