01/04: derivations: Determine what's built in 'check' mode.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 58c08df0544bc39b3b5a8f6638f776159b6b8d8e
Author: Ludovic Courtès <address@hidden>
Date:   Wed Dec 9 10:30:03 2015 +0100

    derivations: Determine what's built in 'check' mode.
    
    * guix/derivations.scm (substitution-oracle): Add #:mode parameter and
    honor it.
    (derivation-prerequisites-to-build): Likewise.
    [derivation-built?]: Take it into account.
    * guix/ui.scm (show-what-to-build): Add #:mode parameter.  Pass it to
    'substitute-oracle' and 'derivations-prerequisites-to-build'.
    * tests/derivations.scm ("derivation-prerequisites-to-build in 'check'
    mode"): New test.
---
 guix/derivations.scm  |   23 ++++++++++++++++-------
 guix/ui.scm           |   12 +++++++-----
 tests/derivations.scm |   20 ++++++++++++++++++++
 3 files changed, 43 insertions(+), 12 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 342a6c8..8a0feca 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 581fb94..35a6671 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 9fc96c7..1bbc93f 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)