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 @@ input list as a monadic value."
(((? 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 @@ The other arguments are as for 'derivation'."
(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 @@ and in the current monad setting (system type, etc.)"
(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 @@ package/derivation references."
(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 @@
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 @@ input list as a monadic value."
(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 @@
#: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 @@
(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))