gexp: Add support for 'origin?' objects in 'ungexp' forms.

* guix/gexp.scm (lower-inputs, gexp-inputs, gexp->sexp,
  canonicalize-reference): Add 'origin?' case.
* guix/monads.scm (origin->derivation): New procedure.
* tests/gexp.scm ("one input origin"): New test.
This commit is contained in:
Ludovic Courtès 2014-05-01 16:15:00 +02:00
parent 696893801c
commit 79c0c8cdf7
3 changed files with 28 additions and 2 deletions

View file

@ -85,6 +85,9 @@ (define (lower-inputs inputs)
(((? package? package) sub-drv ...) (((? package? package) sub-drv ...)
(mlet %store-monad ((drv (package->derivation package))) (mlet %store-monad ((drv (package->derivation package)))
(return `(,drv ,@sub-drv)))) (return `(,drv ,@sub-drv))))
(((? origin? origin) sub-drv ...)
(mlet %store-monad ((drv (origin->derivation origin)))
(return `(,drv ,@sub-drv))))
(input (input
(return input))) (return input)))
inputs)))) inputs))))
@ -158,6 +161,8 @@ (define (add-reference-inputs ref result)
(cons ref result)) (cons ref result))
(((? package?) (? string?)) (((? package?) (? string?))
(cons ref result)) (cons ref result))
(((? origin?) (? string?))
(cons ref result))
((? gexp? exp) ((? gexp? exp)
(append (gexp-inputs exp) result)) (append (gexp-inputs exp) result))
(((? string? file)) (((? string? file))
@ -199,6 +204,9 @@ (define (reference->sexp ref)
(return (derivation->output-path drv output))) (return (derivation->output-path drv output)))
(((? package? p) (? string? output)) (((? package? p) (? string? output))
(package-file p #:output output)) (package-file p #:output output))
(((? origin? o) (? string? output))
(mlet %store-monad ((drv (origin->derivation o)))
(return (derivation->output-path drv output))))
(($ <output-ref> output) (($ <output-ref> output)
;; Output file names are not known in advance but the daemon defines ;; Output file names are not known in advance but the daemon defines
;; an environment variable for each of them at build time, so use ;; an environment variable for each of them at build time, so use
@ -224,10 +232,14 @@ (define (canonicalize-reference ref)
(match ref (match ref
((? package? p) ((? package? p)
`(,p "out")) `(,p "out"))
((? origin? o)
`(,o "out"))
((? derivation? d) ((? derivation? d)
`(,d "out")) `(,d "out"))
(((? package?) (? string?)) (((? package?) (? string?))
ref) ref)
(((? origin?) (? string?))
ref)
(((? derivation?) (? string?)) (((? derivation?) (? string?))
ref) ref)
((? string? s) ((? string? s)

View file

@ -56,6 +56,7 @@ (define-module (guix monads)
text-file text-file
text-file* text-file*
package-file package-file
origin->derivation
package->derivation package->derivation
built-derivations) built-derivations)
#:replace (imported-modules #:replace (imported-modules
@ -395,6 +396,9 @@ (define derivation-expression
(define package->derivation (define package->derivation
(store-lift package-derivation)) (store-lift package-derivation))
(define origin->derivation
(store-lift package-source-derivation))
(define imported-modules (define imported-modules
(store-lift (@ (guix derivations) imported-modules))) (store-lift (@ (guix derivations) imported-modules)))

View file

@ -21,8 +21,7 @@ (define-module (test-gexp)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module ((guix packages) #:use-module (guix packages)
#:select (package-derivation %current-system))
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages base) #:use-module (gnu packages base)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
@ -83,6 +82,17 @@ (define-syntax-rule (test-assertm name exp)
(package-derivation %store coreutils))) (package-derivation %store coreutils)))
(gexp->sexp* exp))))) (gexp->sexp* exp)))))
(test-assert "one input origin"
(let ((exp (gexp (display (ungexp (package-source coreutils))))))
(and (gexp? exp)
(match (gexp-inputs exp)
(((o "out"))
(eq? o (package-source coreutils))))
(equal? `(display ,(derivation->output-path
(package-source-derivation
%store (package-source coreutils))))
(gexp->sexp* exp)))))
(test-assert "same input twice" (test-assert "same input twice"
(let ((exp (gexp (begin (let ((exp (gexp (begin
(display (ungexp coreutils)) (display (ungexp coreutils))