TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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:
Ludovic Courtès 2019-12-06 23:04:57 +01:00
parent 2617d956d8
commit fcbe4f71ca
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 51 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
guix/derivations.scm
View File

@ -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)

18
tests/derivations.scm
View File

@ -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"