From b013c33f6f060c14ca7d1f3cfcb5d8ce3ef1c53c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Oct 2016 18:56:48 +0200 Subject: grafts: 'graft-derivation' does now introduce grafts that shadow other grafts. Partly fixes . * 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. --- guix/grafts.scm | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) (limited to 'guix/grafts.scm') 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 + (($ (? 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) -- cgit v1.2.3 From 783ae212c213d6194ecbbdb13b91d93a6644a1ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Oct 2016 16:38:07 +0200 Subject: grafts: Remove unused variables and confusing monad use. * guix/grafts.scm (cumulative-grafts)[return/cache]: Use %STATE-MONAD, not %STORE-MONAD. Remove unused 'origins' variable and unnecessary inner 'cache' variable. --- guix/grafts.scm | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) (limited to 'guix/grafts.scm') diff --git a/guix/grafts.scm b/guix/grafts.scm index 3e7a81a4c7..80ae27e9b0 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -253,7 +253,7 @@ derivations to the corresponding set of grafts." (state-return grafts)))) (define (return/cache cache value) - (mbegin %store-monad + (mbegin %state-monad (set-current-state (vhash-consq drv value cache)) (return value))) @@ -266,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) -- cgit v1.2.3