[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/08: derivations: Add 'derivation-input-fold'.
From: |
guix-commits |
Subject: |
02/08: derivations: Add 'derivation-input-fold'. |
Date: |
Fri, 6 Dec 2019 18:28:10 -0500 (EST) |
civodul pushed a commit to branch wip-system-bootstrap
in repository guix.
commit 14fc2ef969bda757709f6edb853bbf8fa3b608e7
Author: Ludovic Courtès <address@hidden>
Date: Fri Dec 6 23:04:57 2019 +0100
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.
---
guix/derivations.scm | 52 ++++++++++++++++++++++++++++++++-------------------
tests/derivations.scm | 18 ++++++++++++++++++
2 files changed, 51 insertions(+), 19 deletions(-)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 6cdf55b..480a65c 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 6a7fad8..ef6cec6 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"
- branch wip-system-bootstrap created (now 6ab64e3), guix-commits, 2019/12/06
- 01/08: machine: ssh: Deprecate missing 'host-key' field., guix-commits, 2019/12/06
- 04/08: monads: Add portability to Guile 2.0., guix-commits, 2019/12/06
- 03/08: utils: 'version-compare' delays 'dynamic-link' code., guix-commits, 2019/12/06
- 02/08: derivations: Add 'derivation-input-fold'.,
guix-commits <=
- 06/08: DRAFT gexp: Add 'raw-derivation-closure'., guix-commits, 2019/12/06
- 05/08: DRAFT gexp: Add 'raw-derivation-file'., guix-commits, 2019/12/06
- 07/08: DRAFT gexp: Add 'object-sources'., guix-commits, 2019/12/06
- 08/08: DRAFT system: Add (gnu system bootstrap)., guix-commits, 2019/12/06