M guix/profiles.scm => guix/profiles.scm +48 -52
@@ 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."
M guix/scripts/package.scm => guix/scripts/package.scm +15 -20
@@ 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?)
M tests/profiles.scm => tests/profiles.scm +2 -2
@@ 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