01/04: derivations: Add a 'cut?' parameter to 'derivation-prerequisites'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 3681db5d2c3c40f8796703325242998bbdb48403
Author: Ludovic Courtès <address@hidden>
Date:   Wed Mar 25 09:42:45 2015 +0100

    derivations: Add a 'cut?' parameter to 'derivation-prerequisites'.
    
    * guix/derivations.scm (valid-derivation-input?): New procedure.
      (derivation-prerequisites): Add 'cut?' parameter and honor it.
    * tests/derivations.scm ("derivation-prerequisites and
      derivation-input-is-valid?"): New test.
---
 guix/derivations.scm  |   20 +++++++++++++++++---
 tests/derivations.scm |   14 ++++++++++++++
 2 files changed, 31 insertions(+), 3 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 9b5ee36..8daad4b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -60,6 +60,7 @@
             derivation-input-path
             derivation-input-sub-derivations
             derivation-input-output-paths
+            valid-derivation-input?
 
             &derivation-error
             derivation-error?
@@ -187,12 +188,25 @@ download with a fixed hash (aka. `fetchurl')."
      (map (cut derivation-path->output-path path <>)
           sub-drvs))))
 
-(define (derivation-prerequisites drv)
-  "Return the list of derivation-inputs required to build DRV, recursively."
+(define (valid-derivation-input? store input)
+  "Return true if INPUT is valid--i.e., if all the outputs it requests are in
+the store."
+  (every (cut valid-path? store <>)
+         (derivation-input-output-paths input)))
+
+(define* (derivation-prerequisites drv #:optional (cut? (const #f)))
+  "Return the list of derivation-inputs required to build DRV, recursively.
+
+CUT? is a predicate that is passed a derivation-input and returns true to
+eliminate the given input and its dependencies from the search.  An example of
+search a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
+result is the set of prerequisites of DRV not already in valid."
   (let loop ((drv       drv)
              (result    '())
              (input-set (set)))
-    (let ((inputs (remove (cut set-contains? input-set <>)
+    (let ((inputs (remove (lambda (input)
+                            (or (set-contains? input-set input)
+                                (cut? input)))
                           (derivation-inputs drv))))
       (fold2 loop
              (append inputs result)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 72d253c..a8cccac 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -499,6 +499,20 @@
            (string=? path (derivation-file-name (%guile-for-build)))))
          (derivation-prerequisites drv))))
 
+(test-assert "derivation-prerequisites and derivation-input-is-valid?"
+  (let* ((a (build-expression->derivation %store "a" '(mkdir %output)))
+         (b (build-expression->derivation %store "b" `(list ,(random-text))))
+         (c (build-expression->derivation %store "c" `(mkdir %output)
+                                          #:inputs `(("a" ,a) ("b" ,b)))))
+    (build-derivations %store (list a))
+    (match (derivation-prerequisites c
+                                     (cut valid-derivation-input? %store
+                                          <>))
+      ((($ <derivation-input> file ("out")))
+       (string=? file (derivation-file-name b)))
+      (x
+       (pk 'fail x #f)))))
+
 (test-assert "build-expression->derivation without inputs"
   (let* ((builder    '(begin
                         (mkdir %output)