diff options
| -rw-r--r-- | guix/derivations.scm | 31 | ||||
| -rw-r--r-- | guix/ui.scm | 25 | ||||
| -rw-r--r-- | tests/derivations.scm | 6 |
3 files changed, 36 insertions, 26 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 5e457f1893..b9ad9c9e8c 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -334,13 +334,13 @@ substituter many times." (mode (build-mode normal)) (outputs (derivation-output-names drv)) - (substitutable? + (substitutable-info (substitution-oracle store (list drv) #:mode mode))) "Return two values: the list of derivation-inputs required to build the OUTPUTS of DRV and not already available in STORE, recursively, and the list -of required store paths that can be substituted. SUBSTITUTABLE? must be a +of required store paths that can be substituted. SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned by 'substitution-oracle'." (define built? (cut valid-path? store <>)) @@ -351,7 +351,7 @@ one-argument procedure similar to that returned by 'substitution-oracle'." (define input-substitutable? ;; Return true if and only if all of SUB-DRVS are subsitutable. If at ;; least one is missing, then everything must be rebuilt. - (compose (cut every substitutable? <>) derivation-input-output-paths)) + (compose (cut every substitutable-info <>) derivation-input-output-paths)) (define (derivation-built? drv* sub-drvs) ;; In 'check' mode, assume that DRV is not built. @@ -359,20 +359,24 @@ one-argument procedure similar to that returned by 'substitution-oracle'." (eq? drv* drv))) (every built? (derivation-output-paths drv* sub-drvs)))) - (define (derivation-substitutable? drv sub-drvs) + (define (derivation-substitutable-info drv sub-drvs) (and (substitutable-derivation? drv) - (every substitutable? (derivation-output-paths drv sub-drvs)))) + (let ((info (filter-map substitutable-info + (derivation-output-paths drv sub-drvs)))) + (and (= (length info) (length sub-drvs)) + info)))) (let loop ((drv drv) (sub-drvs outputs) - (build '()) - (substitute '())) + (build '()) ;list of <derivation-input> + (substitute '())) ;list of <substitutable> (cond ((derivation-built? drv sub-drvs) (values build substitute)) - ((derivation-substitutable? drv sub-drvs) - (values build - (append (derivation-output-paths drv sub-drvs) - substitute))) + ((derivation-substitutable-info drv sub-drvs) + => + (lambda (substitutables) + (values build + (append substitutables substitute)))) (else (let ((build (if (substitutable-derivation? drv) build @@ -389,8 +393,9 @@ one-argument procedure similar to that returned by 'substitution-oracle'." (append (append-map (lambda (input) (if (and (not (input-built? input)) (input-substitutable? input)) - (derivation-input-output-paths - input) + (map substitutable-info + (derivation-input-output-paths + input)) '())) (derivation-inputs drv)) substitute) diff --git a/guix/ui.scm b/guix/ui.scm index 9e0fa26d19..9b64648964 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -588,7 +588,7 @@ error." derivations listed in DRV using MODE, a 'build-mode' value. Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are available for download." - (define substitutable? + (define substitutable-info ;; Call 'substitutation-oracle' upfront so we don't end up launching the ;; substituter many times. This makes a big difference, especially when ;; DRV is a long list as is the case with 'guix environment'. @@ -600,7 +600,7 @@ report what is prerequisites are available for download." (or (null? (derivation-outputs drv)) (let ((out (derivation->output-path drv))) ;XXX: assume "out" exists (or (valid-path? store out) - (substitutable? out))))) + (substitutable-info out))))) (let*-values (((build download) (fold2 (lambda (drv build download) @@ -608,7 +608,8 @@ report what is prerequisites are available for download." (derivation-prerequisites-to-build store drv #:mode mode - #:substitutable? substitutable?))) + #:substitutable-info + substitutable-info))) (values (append b build) (append d download)))) '() '() @@ -622,11 +623,13 @@ report what is prerequisites are available for download." (if use-substitutes? (delete-duplicates (append download - (remove (cut valid-path? store <>) - (append-map - substitutable-references - (substitutable-path-info store - download))))) + (filter-map (lambda (item) + (if (valid-path? store item) + #f + (substitutable-info item))) + (append-map + substitutable-references + download)))) download))) ;; TODO: Show the installed size of DOWNLOAD. (if dry-run? @@ -640,7 +643,8 @@ report what is prerequisites are available for download." (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" (length download)) - (null? download) download)) + (null? download) + (map substitutable-path download))) (begin (format (current-error-port) (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" @@ -651,7 +655,8 @@ report what is prerequisites are available for download." (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" (length download)) - (null? download) download))) + (null? download) + (map substitutable-path download)))) (pair? build))) (define show-what-to-build* diff --git a/tests/derivations.scm b/tests/derivations.scm index d4e1a32bb6..f3aad1b906 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -831,10 +831,10 @@ (derivation-prerequisites-to-build store drv)) ((build* download*) (derivation-prerequisites-to-build store drv - #:substitutable? + #:substitutable-info (const #f)))) (and (null? build) - (equal? download (list output)) + (equal? (map substitutable-path download) (list output)) (null? download*) (null? build*)))))) @@ -879,7 +879,7 @@ ;; See <http://bugs.gnu.org/18747>. (and (null? build) (match download - (((? string? item)) + (((= substitutable-path item)) (string=? item (derivation->output-path drv)))))))))) (test-assert "derivation-prerequisites-to-build in 'check' mode" |