diff options
| -rw-r--r-- | guix/derivations.scm | 23 | ||||
| -rw-r--r-- | guix/ui.scm | 12 | ||||
| -rw-r--r-- | tests/derivations.scm | 20 |
3 files changed, 43 insertions, 12 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 342a6c83f3..8a0fecaaee 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -239,7 +239,8 @@ result is the set of prerequisites of DRV not already in valid." (derivation-output-path (assoc-ref outputs sub-drv))) sub-drvs)))) -(define* (substitution-oracle store drv) +(define* (substitution-oracle store drv + #:key (mode (build-mode normal))) "Return a one-argument procedure that, when passed a store file name, returns #t if it's substitutable and #f otherwise. The returned procedure knows about all substitutes for all the derivations listed in DRV, *except* @@ -271,9 +272,12 @@ substituter many times." (let ((self (match (derivation->output-paths drv) (((names . paths) ...) paths)))) - (if (every valid? self) - result - (cons* self (dependencies drv) result)))) + (cond ((eqv? mode (build-mode check)) + (cons (dependencies drv) result)) + ((every valid? self) + result) + (else + (cons* self (dependencies drv) result))))) '() drv)))) (subst (list->set (substitutable-paths store paths)))) @@ -281,11 +285,13 @@ substituter many times." (define* (derivation-prerequisites-to-build store drv #:key + (mode (build-mode normal)) (outputs (derivation-output-names drv)) (substitutable? (substitution-oracle store - (list drv)))) + (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 @@ -301,8 +307,11 @@ one-argument procedure similar to that returned by 'substitution-oracle'." ;; least one is missing, then everything must be rebuilt. (compose (cut every substitutable? <>) derivation-input-output-paths)) - (define (derivation-built? drv sub-drvs) - (every built? (derivation-output-paths drv sub-drvs))) + (define (derivation-built? drv* sub-drvs) + ;; In 'check' mode, assume that DRV is not built. + (and (not (and (eqv? mode (build-mode check)) + (eq? drv* drv))) + (every built? (derivation-output-paths drv* sub-drvs)))) (define (derivation-substitutable? drv sub-drvs) (and (substitutable-derivation? drv) diff --git a/guix/ui.scm b/guix/ui.scm index 581fb941f5..35a6671a07 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -531,17 +531,18 @@ error." (derivation-outputs derivation)))) (define* (show-what-to-build store drv - #:key dry-run? (use-substitutes? #t)) + #:key dry-run? (use-substitutes? #t) + (mode (build-mode normal))) "Show what will or would (depending on DRY-RUN?) be built in realizing the -derivations listed in DRV. Return #t if there's something to build, #f -otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are -available for download." +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? ;; 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'. (if use-substitutes? - (substitution-oracle store drv) + (substitution-oracle store drv #:mode mode) (const #f))) (define (built-or-substitutable? drv) @@ -555,6 +556,7 @@ available for download." (let-values (((b d) (derivation-prerequisites-to-build store drv + #:mode mode #:substitutable? substitutable?))) (values (append b build) (append d download)))) diff --git a/tests/derivations.scm b/tests/derivations.scm index 9fc96c71ae..1bbc93fe5c 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -670,6 +670,26 @@ (((? string? item)) (string=? item (derivation->output-path drv)))))))))) +(test-assert "derivation-prerequisites-to-build in 'check' mode" + (with-store store + (let* ((dep (build-expression->derivation store "dep" + `(begin ,(random-text) + (mkdir %output)))) + (drv (build-expression->derivation store "to-check" + '(mkdir %output) + #:inputs `(("dep" ,dep))))) + (build-derivations store (list drv)) + (delete-paths store (list (derivation->output-path dep))) + + ;; In 'check' mode, DEP must be rebuilt. + (and (null? (derivation-prerequisites-to-build store drv)) + (match (derivation-prerequisites-to-build store drv + #:mode (build-mode + check)) + ((input) + (string=? (derivation-input-path input) + (derivation-file-name dep)))))))) + (test-assert "build-expression->derivation with expression returning #f" (let* ((builder '(begin (mkdir %output) |