summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/grafts.scm32
-rw-r--r--guix/import/utils.scm1
-rw-r--r--guix/packages.scm6
-rw-r--r--guix/scripts/graph.scm53
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."