mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-23 21:17:11 -05:00
Add derivation-prerequisites' and
derivation-prerequisites-to-build'.
* guix/derivations.scm (derivation-prerequisites, derivation-prerequisites-to-build): New procedures. * tests/derivations.scm ("build-expression->derivation and derivation-prerequisites", "build-expression->derivation and derivation-prerequisites-to-build"): New tests.
This commit is contained in:
parent
31ef99a8a5
commit
9a20830e57
2 changed files with 60 additions and 2 deletions
|
@ -26,19 +26,24 @@ (define-module (guix derivations)
|
|||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix utils)
|
||||
#:export (derivation?
|
||||
#:export (<derivation>
|
||||
derivation?
|
||||
derivation-outputs
|
||||
derivation-inputs
|
||||
derivation-sources
|
||||
derivation-system
|
||||
derivation-builder-arguments
|
||||
derivation-builder-environment-vars
|
||||
derivation-prerequisites
|
||||
derivation-prerequisites-to-build
|
||||
|
||||
<derivation-output>
|
||||
derivation-output?
|
||||
derivation-output-path
|
||||
derivation-output-hash-algo
|
||||
derivation-output-hash
|
||||
|
||||
<derivation-input>
|
||||
derivation-input?
|
||||
derivation-input-path
|
||||
derivation-input-sub-derivations
|
||||
|
@ -92,6 +97,42 @@ (define (fixed-output-derivation? drv)
|
|||
#t)
|
||||
(_ #f)))
|
||||
|
||||
(define (derivation-prerequisites drv)
|
||||
"Return the list of derivation-inputs required to build DRV, recursively."
|
||||
(let loop ((drv drv)
|
||||
(result '()))
|
||||
(let ((inputs (remove (cut member <> result) ; XXX: quadratic
|
||||
(derivation-inputs drv))))
|
||||
(fold loop
|
||||
(append inputs result)
|
||||
(map (lambda (i)
|
||||
(call-with-input-file (derivation-input-path i)
|
||||
read-derivation))
|
||||
inputs)))))
|
||||
|
||||
(define (derivation-prerequisites-to-build store drv)
|
||||
"Return the list of derivation-inputs required to build DRV and not already
|
||||
available in STORE, recursively."
|
||||
(define input-built?
|
||||
(match-lambda
|
||||
(($ <derivation-input> path sub-drvs)
|
||||
(let ((out (map (cut derivation-path->output-path path <>)
|
||||
sub-drvs)))
|
||||
(any (cut valid-path? store <>) out)))))
|
||||
|
||||
(let loop ((drv drv)
|
||||
(result '()))
|
||||
(let ((inputs (remove (lambda (i)
|
||||
(or (member i result) ; XXX: quadratic
|
||||
(input-built? i)))
|
||||
(derivation-inputs drv))))
|
||||
(fold loop
|
||||
(append inputs result)
|
||||
(map (lambda (i)
|
||||
(call-with-input-file (derivation-input-path i)
|
||||
read-derivation))
|
||||
inputs)))))
|
||||
|
||||
(define (read-derivation drv-port)
|
||||
"Read the derivation from DRV-PORT and return the corresponding
|
||||
<derivation> object."
|
||||
|
|
|
@ -172,7 +172,16 @@ (define %coreutils
|
|||
(and (valid-path? %store p)
|
||||
(file-exists? (string-append p "/good")))))))
|
||||
|
||||
(test-skip (if (%guile-for-build) 0 4))
|
||||
(test-skip (if (%guile-for-build) 0 6))
|
||||
|
||||
(test-assert "build-expression->derivation and derivation-prerequisites"
|
||||
(let-values (((drv-path drv)
|
||||
(build-expression->derivation %store "fail" (%current-system)
|
||||
#f '())))
|
||||
(any (match-lambda
|
||||
(($ <derivation-input> path)
|
||||
(string=? path (%guile-for-build))))
|
||||
(derivation-prerequisites drv))))
|
||||
|
||||
(test-assert "build-expression->derivation without inputs"
|
||||
(let* ((builder '(begin
|
||||
|
@ -188,6 +197,14 @@ (define %coreutils
|
|||
(equal? '(hello guix)
|
||||
(call-with-input-file (string-append p "/test") read))))))
|
||||
|
||||
(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
|
||||
(let-values (((drv-path drv)
|
||||
(build-expression->derivation %store "fail" (%current-system)
|
||||
#f '())))
|
||||
;; The only direct dependency is (%guile-for-build) and it's already
|
||||
;; built.
|
||||
(null? (derivation-prerequisites-to-build %store drv))))
|
||||
|
||||
(test-assert "build-expression->derivation with expression returning #f"
|
||||
(let* ((builder '(begin
|
||||
(mkdir %output)
|
||||
|
|
Loading…
Reference in a new issue