aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-03-25 09:42:45 +0100
committerLudovic Courtès <ludo@gnu.org>2015-03-25 10:46:22 +0100
commit3681db5d2c3c40f8796703325242998bbdb48403 (patch)
tree74053006d0f8614097460290efc6f50c5460d155
parent1f4344574567337a7e32b97f8cb98104deb71666 (diff)
downloadguix-3681db5d2c3c40f8796703325242998bbdb48403.tar
guix-3681db5d2c3c40f8796703325242998bbdb48403.tar.gz
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.
-rw-r--r--guix/derivations.scm20
-rw-r--r--tests/derivations.scm14
2 files changed, 31 insertions, 3 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 9b5ee367b6..8daad4b81d 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 72d253c465..a8cccac34a 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)