summaryrefslogtreecommitdiff
path: root/guix/grafts.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-10-14 18:56:48 +0200
committerLudovic Courtès <ludo@gnu.org>2016-10-14 23:31:50 +0200
commitb013c33f6f060c14ca7d1f3cfcb5d8ce3ef1c53c (patch)
treef83963c52c49c32d4d8de8ac49c1b45e751548c5 /guix/grafts.scm
parentd0025d01445ff271ececea20cfa6a2346593d1d6 (diff)
grafts: 'graft-derivation' does now introduce grafts that shadow other grafts.
Partly fixes <http://bugs.gnu.org/24418>. * guix/grafts.scm (cumulative-grafts)[graft-origin?]: New procedure. [dependency-grafts]: Use it in new 'if' around recursive call. * tests/grafts.scm ("graft-derivation, grafts are not shadowed"): New test.
Diffstat (limited to 'guix/grafts.scm')
-rw-r--r--guix/grafts.scm24
1 files changed, 20 insertions, 4 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 53e697688a..3e7a81a4c7 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -227,13 +227,29 @@ 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)