diff options
| -rw-r--r-- | guix/profiles.scm | 100 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 35 | ||||
| -rw-r--r-- | tests/profiles.scm | 4 |
3 files changed, 65 insertions, 74 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm index 91fc2fa435..64c69c4429 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -22,6 +22,7 @@ #:use-module (guix records) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 ftw) @@ -39,7 +40,7 @@ manifest-entry-name manifest-entry-version manifest-entry-output - manifest-entry-path + manifest-entry-item manifest-entry-dependencies manifest-pattern @@ -84,7 +85,7 @@ (version manifest-entry-version) ; string (output manifest-entry-output ; string (default "out")) - (path manifest-entry-path) ; store path + (item manifest-entry-item) ; package | store path (dependencies manifest-entry-dependencies ; list of store paths (default '())) (inputs manifest-entry-inputs ; list of inputs to build @@ -106,17 +107,20 @@ (call-with-input-file file read-manifest) (manifest '())))) -(define (manifest->sexp manifest) - "Return a representation of MANIFEST as an sexp." - (define (entry->sexp entry) +(define (manifest->gexp manifest) + "Return a representation of MANIFEST as a gexp." + (define (entry->gexp entry) (match entry - (($ <manifest-entry> name version path output (deps ...)) - (list name version path output deps)))) + (($ <manifest-entry> name version output (? string? path) (deps ...)) + #~(#$name #$version #$output #$path #$deps)) + (($ <manifest-entry> name version output (? package? package) (deps ...)) + #~(#$name #$version #$output + (ungexp package (or output "out")) #$deps)))) (match manifest (($ <manifest> (entries ...)) - `(manifest (version 1) - (packages ,(map entry->sexp entries)))))) + #~(manifest (version 1) + (packages #$(map entry->gexp entries)))))) (define (sexp->manifest sexp) "Parse SEXP as a manifest." @@ -129,7 +133,7 @@ (name name) (version version) (output output) - (path path))) + (item path))) name version output path))) ;; Version 1 adds a list of propagated inputs to the @@ -142,7 +146,7 @@ (name name) (version version) (output output) - (path path) + (item path) (dependencies deps))) name version output path deps))) @@ -200,50 +204,42 @@ must be a manifest-pattern." ;;; Profiles. ;;; -(define* (lower-input store input #:optional (system (%current-system))) - "Lower INPUT so that it contains derivations instead of packages." - (match input - ((name (? package? package)) - `(,name ,(package-derivation store package system))) - ((name (? package? package) output) - `(,name ,(package-derivation store package system) - ,output)) - (_ input))) - -(define (profile-derivation store manifest) +(define (profile-derivation manifest) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST." + (define inputs + (append-map (match-lambda + (($ <manifest-entry> name version + output path deps (inputs ..1)) + inputs) + (($ <manifest-entry> name version output path deps) + ;; Assume PATH and DEPS are already valid. + `((,name ,path) ,@deps))) + (manifest-entries manifest))) + (define builder - `(begin - (use-modules (ice-9 pretty-print) - (guix build union)) - - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let ((output (assoc-ref %outputs "out")) - (inputs (map cdr %build-inputs))) - (union-build output inputs - #:log-port (%make-void-port "w")) - (call-with-output-file (string-append output "/manifest") - (lambda (p) - (pretty-print ',(manifest->sexp manifest) p)))))) - - (build-expression->derivation store "profile" builder - #:inputs - (append-map (match-lambda - (($ <manifest-entry> name version - output path deps (inputs ..1)) - (map (cute lower-input store <>) - inputs)) - (($ <manifest-entry> name version - output path deps) - ;; Assume PATH and DEPS are - ;; already valid. - `((,name ,path) ,@deps))) - (manifest-entries manifest)) - #:modules '((guix build union)) - #:local-build? #t)) + #~(begin + (use-modules (ice-9 pretty-print) + (guix build union)) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let ((inputs '#$(map (match-lambda + ((label thing) + thing) + ((label thing output) + `(,thing ,output))) + inputs))) + (union-build #$output inputs + #:log-port (%make-void-port "w")) + (call-with-output-file (string-append #$output "/manifest") + (lambda (p) + (pretty-print '#$(manifest->gexp manifest) p)))))) + + (gexp->derivation "profile" builder + #:modules '((guix build union)) + #:local-build? #t)) (define (profile-regexp profile) "Return a regular expression that matches PROFILE's name and number." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 36e025d479..bc2c854853 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -24,6 +24,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) + #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix config) #:use-module (guix scripts build) @@ -82,7 +83,8 @@ return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if (define (link-to-empty-profile generation) "Link GENERATION, a string, to the empty profile." - (let* ((drv (profile-derivation (%store) (manifest '()))) + (let* ((drv (run-with-store (%store) + (profile-derivation (manifest '())))) (prof (derivation->output-path drv "out"))) (when (not (build-derivations (%store) (list drv))) (leave (_ "failed to build the empty profile~%"))) @@ -205,10 +207,14 @@ packages that will/would be installed and removed." remove)))) (_ #f)) (match install - ((($ <manifest-entry> name version output path _) ..1) + ((($ <manifest-entry> name version output item _) ..1) (let ((len (length name)) - (install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>) - name version output path))) + (install (map (lambda (name version output item) + (format #f " ~a-~a\t~a\t~a" name version output + (if (package? item) + (package-output (%store) item output) + item))) + name version output item))) (if dry-run? (format (current-error-port) (N_ "The following package would be installed:~%~{~a~%~}~%" @@ -253,17 +259,6 @@ RX." (package-name p2)))) same-location?)) -(define (input->name+path input) - "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." - (let loop ((input input)) - (match input - ((name (? package? package)) - (loop `(,name ,package "out"))) - ((name (? package? package) sub-drv) - `(,name ,(package-output (%store) package sub-drv))) - (_ - input)))) - (define %sigint-prompt ;; The prompt to jump to upon SIGINT. (make-prompt-tag "interruptible")) @@ -652,14 +647,13 @@ return the new list of manifest entries." ;; When given a package via `-e', install the first of its ;; outputs (XXX). (let* ((output (or output (car (package-outputs p)))) - (path (package-output (%store) p output)) (deps (deduplicate (package-transitive-propagated-inputs p)))) (manifest-entry (name (package-name p)) (version (package-version p)) (output output) - (path path) - (dependencies (map input->name+path deps)) + (item p) + (dependencies deps) (inputs (cons (list (package-name p) p output) deps))))) @@ -723,7 +717,7 @@ return the new list of manifest entries." (name name) (version version) (output #f) - (path path)))) + (item path)))) (_ #f)) opts))) @@ -932,7 +926,8 @@ more information.~%")) (ensure-default-profile)) (unless (and (null? install) (null? remove)) - (let* ((prof-drv (profile-derivation (%store) new)) + (let* ((prof-drv (run-with-store (%store) + (profile-derivation new))) (prof (derivation->output-path prof-drv)) (remove (manifest-matching-entries manifest remove))) (show-what-to-remove/install remove install dry-run?) diff --git a/tests/profiles.scm b/tests/profiles.scm index 8ead6e6968..e6fcaad7cf 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,7 +30,7 @@ (manifest-entry (name "guile") (version "2.0.9") - (path "/gnu/store/...") + (item "/gnu/store/...") (output "out"))) (define guile-2.0.9:debug |