mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -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 (ice-9 rdelim)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:export (derivation?
|
#:export (<derivation>
|
||||||
|
derivation?
|
||||||
derivation-outputs
|
derivation-outputs
|
||||||
derivation-inputs
|
derivation-inputs
|
||||||
derivation-sources
|
derivation-sources
|
||||||
derivation-system
|
derivation-system
|
||||||
derivation-builder-arguments
|
derivation-builder-arguments
|
||||||
derivation-builder-environment-vars
|
derivation-builder-environment-vars
|
||||||
|
derivation-prerequisites
|
||||||
|
derivation-prerequisites-to-build
|
||||||
|
|
||||||
|
<derivation-output>
|
||||||
derivation-output?
|
derivation-output?
|
||||||
derivation-output-path
|
derivation-output-path
|
||||||
derivation-output-hash-algo
|
derivation-output-hash-algo
|
||||||
derivation-output-hash
|
derivation-output-hash
|
||||||
|
|
||||||
|
<derivation-input>
|
||||||
derivation-input?
|
derivation-input?
|
||||||
derivation-input-path
|
derivation-input-path
|
||||||
derivation-input-sub-derivations
|
derivation-input-sub-derivations
|
||||||
|
@ -92,6 +97,42 @@ (define (fixed-output-derivation? drv)
|
||||||
#t)
|
#t)
|
||||||
(_ #f)))
|
(_ #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)
|
(define (read-derivation drv-port)
|
||||||
"Read the derivation from DRV-PORT and return the corresponding
|
"Read the derivation from DRV-PORT and return the corresponding
|
||||||
<derivation> object."
|
<derivation> object."
|
||||||
|
|
|
@ -172,7 +172,16 @@ (define %coreutils
|
||||||
(and (valid-path? %store p)
|
(and (valid-path? %store p)
|
||||||
(file-exists? (string-append p "/good")))))))
|
(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"
|
(test-assert "build-expression->derivation without inputs"
|
||||||
(let* ((builder '(begin
|
(let* ((builder '(begin
|
||||||
|
@ -188,6 +197,14 @@ (define %coreutils
|
||||||
(equal? '(hello guix)
|
(equal? '(hello guix)
|
||||||
(call-with-input-file (string-append p "/test") read))))))
|
(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"
|
(test-assert "build-expression->derivation with expression returning #f"
|
||||||
(let* ((builder '(begin
|
(let* ((builder '(begin
|
||||||
(mkdir %output)
|
(mkdir %output)
|
||||||
|
|
Loading…
Reference in a new issue