diff options
| -rw-r--r-- | guix/gexp.scm | 113 | ||||
| -rw-r--r-- | tests/profiles.scm | 9 |
2 files changed, 69 insertions, 53 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index 67329b74df..5be5577595 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -79,6 +79,14 @@ (set-record-type-printer! <gexp> write-gexp) +;; The input of a gexp. +(define-record-type <gexp-input> + (gexp-input thing output native?) + gexp-input? + (thing gexp-input-thing) ;<package> | <origin> | <derivation> | ... + (output gexp-input-output) ;string + (native? gexp-input-native?)) ;Boolean + ;; Reference to one of the derivation's outputs, for gexps used in ;; derivations. (define-record-type <gexp-output> @@ -281,20 +289,27 @@ The other arguments are as for 'derivation'." references." (define (add-reference-inputs ref result) (match ref - (((? derivation?) (? string?)) - (cons ref result)) - (((? package?) (? string?)) - (cons ref result)) - (((? origin?) (? string?)) - (cons ref result)) - ((? gexp? exp) + (($ <gexp-input> (? derivation? drv) output) + (cons `(,drv ,output) result)) + (($ <gexp-input> (? package? pkg) output) + (cons `(,pkg ,output) result)) + (($ <gexp-input> (? origin? o)) + (cons `(,o "out") result)) + (($ <gexp-input> (? gexp? exp)) (append (gexp-inputs exp references) result)) - (((? string? file)) - (if (direct-store-path? file) - (cons ref result) + (($ <gexp-input> (? string? str)) + (if (direct-store-path? str) + (cons `(,str) result) result)) - ((refs ...) - (fold-right add-reference-inputs result refs)) + (($ <gexp-input> ((? package? p) (? string? output)) _ native?) + ;; XXX: For now, for backward-compatibility, automatically convert a + ;; pair like this to an gexp-input for OUTPUT of P. + (add-reference-inputs (gexp-input p output native?) result)) + (($ <gexp-input> (lst ...) output native?) + (fold-right add-reference-inputs result + ;; XXX: For now, automatically convert LST to a list of + ;; gexp-inputs. + (map (cut gexp-input <> output native?) lst))) (_ ;; Ignore references to other kinds of objects. result))) @@ -312,8 +327,12 @@ references." (match ref (($ <gexp-output> name) (cons name result)) - ((? gexp? exp) + (($ <gexp-input> (? gexp? exp)) (append (gexp-outputs exp) result)) + (($ <gexp-input> (lst ...) output native?) + ;; XXX: Automatically convert LST. + (add-reference-output (map (cut gexp-input <> output native?) lst) + result)) ((lst ...) (fold-right add-reference-output result lst)) (_ @@ -330,14 +349,21 @@ and in the current monad setting (system type, etc.)" (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref - (((? derivation? drv) (? string? output)) + (($ <gexp-input> (? derivation? drv) output) (return (derivation->output-path drv output))) - (((? package? p) (? string? output)) + (($ <gexp-input> (? package? p) output n?) (package-file p #:output output #:system system - #:target (if native? #f target))) - (((? origin? o) (? string? output)) + #:target (if (or n? native?) #f target))) + (($ <gexp-input> ((? package? p) (? string? output)) _ n?) + ;; XXX: For backward compatibility, automatically interpret such a + ;; pair. + (package-file p + #:output output + #:system system + #:target (if (or n? native?) #f target))) + (($ <gexp-input> (? origin? o) output) (mlet %store-monad ((drv (origin->derivation o))) (return (derivation->output-path drv output)))) (($ <gexp-output> output) @@ -345,15 +371,19 @@ and in the current monad setting (system type, etc.)" ;; an environment variable for each of them at build time, so use ;; that trick. (return `((@ (guile) getenv) ,output))) - ((? gexp? exp) + (($ <gexp-input> (? gexp? exp) output n?) (gexp->sexp exp #:system system - #:target (if native? #f target))) - (((? string? str)) - (return (if (direct-store-path? str) str ref))) - ((refs ...) + #:target (if (or n? native?) #f target))) + (($ <gexp-input> (refs ...) output n?) (sequence %store-monad - (map (cut reference->sexp <> native?) refs))) + (map (lambda (ref) + ;; XXX: Automatically convert REF to an gexp-input. + (reference->sexp (gexp-input ref "out" + (or n? native?)))) + refs))) + (($ <gexp-input> x) + (return x)) (x (return x))))) @@ -364,28 +394,6 @@ and in the current monad setting (system type, etc.)" (gexp-native-references exp)))))) (return (apply (gexp-proc exp) args)))) -(define (canonicalize-reference ref) - "Return a canonical variant of REF, which adds any missing output part in -package/derivation references." - (match ref - ((? package? p) - `(,p "out")) - ((? origin? o) - `(,o "out")) - ((? derivation? d) - `(,d "out")) - (((? package?) (? string?)) - ref) - (((? origin?) (? string?)) - ref) - (((? derivation?) (? string?)) - ref) - ((? string? s) - (if (direct-store-path? s) `(,s) s)) - ((refs ...) - (map canonicalize-reference refs)) - (x x))) - (define (syntax-location-string s) "Return a string representing the source code location of S." (let ((props (syntax-source s))) @@ -445,17 +453,17 @@ package/derivation references." ((ungexp output name) #'(gexp-output name)) ((ungexp thing) - #'thing) + #'(gexp-input thing "out" #f)) ((ungexp drv-or-pkg out) - #'(list drv-or-pkg out)) + #'(gexp-input drv-or-pkg out #f)) ((ungexp-splicing lst) - #'lst) + #'(gexp-input lst "out" #f)) ((ungexp-native thing) - #'thing) + #'(gexp-input thing "out" #t)) ((ungexp-native drv-or-pkg out) - #'(list drv-or-pkg out)) + #'(gexp-input drv-or-pkg out #t)) ((ungexp-native-splicing lst) - #'lst))) + #'(gexp-input lst "out" #t)))) (define (substitute-ungexp exp substs) ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with @@ -506,8 +514,7 @@ package/derivation references." (sexp (substitute-references #'exp (zip escapes formals))) (refs (map escape->ref normals)) (nrefs (map escape->ref natives))) - #`(make-gexp (map canonicalize-reference (list #,@refs)) - (map canonicalize-reference (list #,@nrefs)) + #`(make-gexp (list #,@refs) (list #,@nrefs) (lambda #,formals #,sexp))))))) diff --git a/tests/profiles.scm b/tests/profiles.scm index 1bac9d94e6..7b942e35b0 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -25,6 +25,7 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (gnu packages bootstrap) + #:use-module ((gnu packages base) #:prefix packages:) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-11) @@ -191,6 +192,14 @@ (string=? (dirname (readlink bindir)) (derivation->output-path guile)))))) +(test-assertm "profile-derivation, inputs" + (mlet* %store-monad + ((entry -> (package->manifest-entry packages:glibc "debug")) + (drv (profile-derivation (manifest (list entry)) + #:info-dir? #f + #:ca-certificate-bundle? #f))) + (return (derivation-inputs drv)))) + (test-end "profiles") |