aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-12-06 23:04:57 +0100
committerLudovic Courtès <ludo@gnu.org>2019-12-07 00:29:41 +0100
commitfcbe4f71ca7ab7f8526bd1643044d204390ec6c2 (patch)
treedb96cfea5053097dadd9e8478569794b5ea4c98a
parent2617d956d8ae122128a1ba2cc74983cbd683b042 (diff)
downloadguix-fcbe4f71ca7ab7f8526bd1643044d204390ec6c2.tar
guix-fcbe4f71ca7ab7f8526bd1643044d204390ec6c2.tar.gz
derivations: Add 'derivation-input-fold'.
* guix/derivations.scm (derivation-input-fold): New procedure. (substitution-oracle)[closure]: Rewrite in terms of 'derivation-input-fold'. * tests/derivations.scm ("derivation-input-fold"): New test.
-rw-r--r--guix/derivations.scm52
-rw-r--r--tests/derivations.scm18
2 files changed, 51 insertions, 19 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 6cdf55b1fe..480a65c78b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -86,6 +86,7 @@
fixed-output-derivation?
offloadable-derivation?
substitutable-derivation?
+ derivation-input-fold
substitution-oracle
derivation-hash
derivation-properties
@@ -303,6 +304,29 @@ result is the set of prerequisites of DRV not already in valid."
(derivation-output-path (assoc-ref outputs sub-drv)))
sub-drvs))))
+(define* (derivation-input-fold proc seed inputs
+ #:key (cut? (const #f)))
+ "Perform a breadth-first traversal of INPUTS, calling PROC on each input
+with the current result, starting from SEED. Skip recursion on inputs that
+match CUT?."
+ (let loop ((inputs inputs)
+ (result seed)
+ (visited (set)))
+ (match inputs
+ (()
+ result)
+ ((input rest ...)
+ (let ((key (derivation-input-key input)))
+ (cond ((set-contains? visited key)
+ (loop rest result visited))
+ ((cut? input)
+ (loop rest result (set-insert key visited)))
+ (else
+ (let ((drv (derivation-input-derivation input)))
+ (loop (append (derivation-inputs drv) rest)
+ (proc input result)
+ (set-insert key visited))))))))))
+
(define* (substitution-oracle store inputs-or-drv
#:key (mode (build-mode normal)))
"Return a one-argument procedure that, when passed a store file name,
@@ -322,25 +346,15 @@ substituter many times."
(cut valid-derivation-input? store <>))
(define (closure inputs)
- (let loop ((inputs inputs)
- (closure '())
- (visited (set)))
- (match inputs
- (()
- (reverse closure))
- ((input rest ...)
- (let ((key (derivation-input-key input)))
- (cond ((set-contains? visited key)
- (loop rest closure visited))
- ((valid-input? input)
- (loop rest closure (set-insert key visited)))
- (else
- (let ((drv (derivation-input-derivation input)))
- (loop (append (derivation-inputs drv) rest)
- (if (substitutable-derivation? drv)
- (cons input closure)
- closure)
- (set-insert key visited))))))))))
+ (reverse
+ (derivation-input-fold (lambda (input closure)
+ (let ((drv (derivation-input-derivation input)))
+ (if (substitutable-derivation? drv)
+ (cons input closure)
+ closure)))
+ '()
+ inputs
+ #:cut? valid-input?)))
(let* ((inputs (closure (map (match-lambda
((? derivation-input? input)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 6a7fad85b5..ef6cec6c76 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -978,6 +978,24 @@
#:mode (build-mode check))
(list drv dep))))))
+(test-assert "derivation-input-fold"
+ (let* ((builder (add-text-to-store %store "my-builder.sh"
+ "echo hello, world > \"$out\"\n"
+ '()))
+ (drv1 (derivation %store "foo"
+ %bash `(,builder)
+ #:sources `(,%bash ,builder)))
+ (drv2 (derivation %store "bar"
+ %bash `(,builder)
+ #:inputs `((,drv1))
+ #:sources `(,%bash ,builder))))
+ (equal? (derivation-input-fold (lambda (input result)
+ (cons (derivation-input-derivation input)
+ result))
+ '()
+ (list (derivation-input drv2)))
+ (list drv1 drv2))))
+
(test-assert "substitution-oracle and #:substitute? #f"
(with-store store
(let* ((dep (build-expression->derivation store "dep"