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.
This commit is contained in:
parent
2617d956d8
commit
fcbe4f71ca
|
@ -86,6 +86,7 @@
|
||||||
fixed-output-derivation?
|
fixed-output-derivation?
|
||||||
offloadable-derivation?
|
offloadable-derivation?
|
||||||
substitutable-derivation?
|
substitutable-derivation?
|
||||||
|
derivation-input-fold
|
||||||
substitution-oracle
|
substitution-oracle
|
||||||
derivation-hash
|
derivation-hash
|
||||||
derivation-properties
|
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)))
|
(derivation-output-path (assoc-ref outputs sub-drv)))
|
||||||
sub-drvs))))
|
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
|
(define* (substitution-oracle store inputs-or-drv
|
||||||
#:key (mode (build-mode normal)))
|
#:key (mode (build-mode normal)))
|
||||||
"Return a one-argument procedure that, when passed a store file name,
|
"Return a one-argument procedure that, when passed a store file name,
|
||||||
|
@ -322,25 +346,15 @@ substituter many times."
|
||||||
(cut valid-derivation-input? store <>))
|
(cut valid-derivation-input? store <>))
|
||||||
|
|
||||||
(define (closure inputs)
|
(define (closure inputs)
|
||||||
(let loop ((inputs inputs)
|
(reverse
|
||||||
(closure '())
|
(derivation-input-fold (lambda (input closure)
|
||||||
(visited (set)))
|
(let ((drv (derivation-input-derivation input)))
|
||||||
(match inputs
|
(if (substitutable-derivation? drv)
|
||||||
(()
|
(cons input closure)
|
||||||
(reverse closure))
|
closure)))
|
||||||
((input rest ...)
|
'()
|
||||||
(let ((key (derivation-input-key input)))
|
inputs
|
||||||
(cond ((set-contains? visited key)
|
#:cut? valid-input?)))
|
||||||
(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))))))))))
|
|
||||||
|
|
||||||
(let* ((inputs (closure (map (match-lambda
|
(let* ((inputs (closure (map (match-lambda
|
||||||
((? derivation-input? input)
|
((? derivation-input? input)
|
||||||
|
|
|
@ -978,6 +978,24 @@
|
||||||
#:mode (build-mode check))
|
#:mode (build-mode check))
|
||||||
(list drv dep))))))
|
(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"
|
(test-assert "substitution-oracle and #:substitute? #f"
|
||||||
(with-store store
|
(with-store store
|
||||||
(let* ((dep (build-expression->derivation store "dep"
|
(let* ((dep (build-expression->derivation store "dep"
|
||||||
|
|
Loading…
Reference in New Issue