nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

profiles: Switch to gexps. 

* guix/profiles.scm (<manifest-entry>)[path]: Rename to...
  [item]: ... this.  Update users.
  (manifest->sexp): Rename to...
  (manifest->gexp): ... this.  Return a gexp.
  (lower-input): Remove.
  (profile-derivation): Remove 'store' parameter, and turn into a
  monadic procedure.
  [inputs]: New variable.
  [builder]: Turn into a gexp.
  Replace call to 'build-expression->derivation' with call to
  'gexp->derivation'.
* guix/scripts/package.scm (link-to-empty-profile): Adjust call to
  'profile-derivation', and wrap it in 'run-with-store'.
  (show-what-to-remove/install): Rename 'path' to 'item'.  Check whether
  ITEM is a package, and return its output path if it is.
  (input->name+path): Remove.
  (options->installable): Set 'item' to P.
  (guix-package): Adjust call to 'profile-derivation'.
* tests/profiles.scm (guile-2.0.9): Change 'path' to 'item'.
This commit is contained in:
Ludovic Courtès 2014-07-26 22:08:10 +02:00
parent 48704e5b5c
commit a54c94a40d
3 changed files with 62 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
guix/profiles.scm
View File

@ -22,6 +22,7 @@
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix gexp)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
@ -39,7 +40,7 @@
manifest-entry-name manifest-entry-name
manifest-entry-version manifest-entry-version
manifest-entry-output manifest-entry-output
manifest-entry-path manifest-entry-item
manifest-entry-dependencies manifest-entry-dependencies
manifest-pattern manifest-pattern
@ -84,7 +85,7 @@
(version manifest-entry-version) ; string (version manifest-entry-version) ; string
(output manifest-entry-output ; string (output manifest-entry-output ; string
(default "out")) (default "out"))
(path manifest-entry-path) ; store path (item manifest-entry-item) ; package | store path
(dependencies manifest-entry-dependencies ; list of store paths (dependencies manifest-entry-dependencies ; list of store paths
(default '())) (default '()))
(inputs manifest-entry-inputs ; list of inputs to build (inputs manifest-entry-inputs ; list of inputs to build
@ -106,17 +107,20 @@
(call-with-input-file file read-manifest) (call-with-input-file file read-manifest)
(manifest '())))) (manifest '()))))
(define (manifest->sexp manifest) (define (manifest->gexp manifest)
"Return a representation of MANIFEST as an sexp." "Return a representation of MANIFEST as a gexp."
(define (entry->sexp entry) (define (entry->gexp entry)
(match entry (match entry
(($ <manifest-entry> name version path output (deps ...)) (($ <manifest-entry> name version output (? string? path) (deps ...))
(list name version path output 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 (match manifest
(($ <manifest> (entries ...)) (($ <manifest> (entries ...))
`(manifest (version 1) #~(manifest (version 1)
(packages ,(map entry->sexp entries)))))) (packages #$(map entry->gexp entries))))))
(define (sexp->manifest sexp) (define (sexp->manifest sexp)
"Parse SEXP as a manifest." "Parse SEXP as a manifest."
@ -129,7 +133,7 @@
(name name) (name name)
(version version) (version version)
(output output) (output output)
(path path))) (item path)))
name version output path))) name version output path)))
;; Version 1 adds a list of propagated inputs to the ;; Version 1 adds a list of propagated inputs to the
@ -142,7 +146,7 @@
(name name) (name name)
(version version) (version version)
(output output) (output output)
(path path) (item path)
(dependencies deps))) (dependencies deps)))
name version output path deps))) name version output path deps)))
@ -200,50 +204,42 @@ must be a manifest-pattern."
;;; Profiles. ;;; Profiles.
;;; ;;;
(define* (lower-input store input #:optional (system (%current-system))) (define (profile-derivation manifest)
"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)
"Return a derivation that builds a profile (aka. 'user environment') with "Return a derivation that builds a profile (aka. 'user environment') with
the given MANIFEST." 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 (define builder
`(begin #~(begin
(use-modules (ice-9 pretty-print) (use-modules (ice-9 pretty-print)
(guix build union)) (guix build union))
(setvbuf (current-output-port) _IOLBF) (setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF) (setvbuf (current-error-port) _IOLBF)
(let ((output (assoc-ref %outputs "out")) (let ((inputs '#$(map (match-lambda
(inputs (map cdr %build-inputs))) ((label thing)
(union-build output inputs thing)
#:log-port (%make-void-port "w")) ((label thing output)
(call-with-output-file (string-append output "/manifest") `(,thing ,output)))
(lambda (p) inputs)))
(pretty-print ',(manifest->sexp manifest) p)))))) (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))))))
(build-expression->derivation store "profile" builder (gexp->derivation "profile" builder
#:inputs #:modules '((guix build union))
(append-map (match-lambda #:local-build? #t))
(($ <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))
(define (profile-regexp profile) (define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number." "Return a regular expression that matches PROFILE's name and number."

35
guix/scripts/package.scm
View File

@ -24,6 +24,7 @@
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix profiles) #:use-module (guix profiles)
#:use-module (guix monads)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix scripts build) #: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) (define (link-to-empty-profile generation)
"Link GENERATION, a string, to the empty profile." "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"))) (prof (derivation->output-path drv "out")))
(when (not (build-derivations (%store) (list drv))) (when (not (build-derivations (%store) (list drv)))
(leave (_ "failed to build the empty profile~%"))) (leave (_ "failed to build the empty profile~%")))
@ -205,10 +207,14 @@ packages that will/would be installed and removed."
remove)))) remove))))
(_ #f)) (_ #f))
(match install (match install
((($ <manifest-entry> name version output path _) ..1) ((($ <manifest-entry> name version output item _) ..1)
(let ((len (length name)) (let ((len (length name))
(install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>) (install (map (lambda (name version output item)
name version output path))) (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? (if dry-run?
(format (current-error-port) (format (current-error-port)
(N_ "The following package would be installed:~%~{~a~%~}~%" (N_ "The following package would be installed:~%~{~a~%~}~%"
@ -253,17 +259,6 @@ RX."
(package-name p2)))) (package-name p2))))
same-location?)) 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 (define %sigint-prompt
;; The prompt to jump to upon SIGINT. ;; The prompt to jump to upon SIGINT.
(make-prompt-tag "interruptible")) (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 ;; When given a package via `-e', install the first of its
;; outputs (XXX). ;; outputs (XXX).
(let* ((output (or output (car (package-outputs p)))) (let* ((output (or output (car (package-outputs p))))
(path (package-output (%store) p output))
(deps (deduplicate (package-transitive-propagated-inputs p)))) (deps (deduplicate (package-transitive-propagated-inputs p))))
(manifest-entry (manifest-entry
(name (package-name p)) (name (package-name p))
(version (package-version p)) (version (package-version p))
(output output) (output output)
(path path) (item p)
(dependencies (map input->name+path deps)) (dependencies deps)
(inputs (cons (list (package-name p) p output) (inputs (cons (list (package-name p) p output)
deps))))) deps)))))
@ -723,7 +717,7 @@ return the new list of manifest entries."
(name name) (name name)
(version version) (version version)
(output #f) (output #f)
(path path)))) (item path))))
(_ #f)) (_ #f))
opts))) opts)))
@ -932,7 +926,8 @@ more information.~%"))
(ensure-default-profile)) (ensure-default-profile))
(unless (and (null? install) (null? remove)) (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)) (prof (derivation->output-path prof-drv))
(remove (manifest-matching-entries manifest remove))) (remove (manifest-matching-entries manifest remove)))
(show-what-to-remove/install remove install dry-run?) (show-what-to-remove/install remove install dry-run?)

4
tests/profiles.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -30,7 +30,7 @@
(manifest-entry (manifest-entry
(name "guile") (name "guile")
(version "2.0.9") (version "2.0.9")
(path "/gnu/store/...") (item "/gnu/store/...")
(output "out"))) (output "out")))
(define guile-2.0.9:debug (define guile-2.0.9:debug