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.
This commit is contained in:
parent
1f43445745
commit
3681db5d2c
|
@ -60,6 +60,7 @@
|
||||||
derivation-input-path
|
derivation-input-path
|
||||||
derivation-input-sub-derivations
|
derivation-input-sub-derivations
|
||||||
derivation-input-output-paths
|
derivation-input-output-paths
|
||||||
|
valid-derivation-input?
|
||||||
|
|
||||||
&derivation-error
|
&derivation-error
|
||||||
derivation-error?
|
derivation-error?
|
||||||
|
@ -187,12 +188,25 @@ download with a fixed hash (aka. `fetchurl')."
|
||||||
(map (cut derivation-path->output-path path <>)
|
(map (cut derivation-path->output-path path <>)
|
||||||
sub-drvs))))
|
sub-drvs))))
|
||||||
|
|
||||||
(define (derivation-prerequisites drv)
|
(define (valid-derivation-input? store input)
|
||||||
"Return the list of derivation-inputs required to build DRV, recursively."
|
"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)
|
(let loop ((drv drv)
|
||||||
(result '())
|
(result '())
|
||||||
(input-set (set)))
|
(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))))
|
(derivation-inputs drv))))
|
||||||
(fold2 loop
|
(fold2 loop
|
||||||
(append inputs result)
|
(append inputs result)
|
||||||
|
|
|
@ -499,6 +499,20 @@
|
||||||
(string=? path (derivation-file-name (%guile-for-build)))))
|
(string=? path (derivation-file-name (%guile-for-build)))))
|
||||||
(derivation-prerequisites drv))))
|
(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"
|
(test-assert "build-expression->derivation without inputs"
|
||||||
(let* ((builder '(begin
|
(let* ((builder '(begin
|
||||||
(mkdir %output)
|
(mkdir %output)
|
||||||
|
|
Loading…
Reference in New Issue