ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 13:28:12 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

profiles: Switch to gexps.

Browse source 
* 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

78
guix/profiles.scm
View file

@ -22,6 +22,7 @@ (define-module (guix profiles)
#: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 @@ (define-module (guix profiles)
manifest-entry-name
manifest-entry-version
manifest-entry-output
manifest-entry-path
manifest-entry-item
manifest-entry-dependencies
manifest-pattern
@ -84,7 +85,7 @@ (define-record-type* <manifest-entry> manifest-entry
(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 @@ (define (profile-manifest profile)
(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 @@ (define (sexp->manifest sexp)
(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 @@ (define (sexp->manifest sexp)
(name name)
(version version)
(output output)
(path path)
(item path)
(dependencies deps)))
name version output path deps)))
@ -200,48 +204,40 @@ (define (matches? entry)
;;; 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
#~(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
(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")
(call-with-output-file (string-append #$output "/manifest")
(lambda (p)
(pretty-print ',(manifest->sexp manifest) p))))))
(pretty-print '#$(manifest->gexp 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))
(gexp->derivation "profile" builder
#:modules '((guix build union))
#:local-build? #t))

35
guix/scripts/package.scm
View file

@ -24,6 +24,7 @@ (define-module (guix scripts package)
#: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 @@ (define (canonicalize-profile profile)
(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 @@ (define (show-what-to-remove/install remove install dry-run?)
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 @@ (define matches?
(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 @@ (define (package->manifest-entry p output)
;; 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 @@ (define to-install
(name name)
(version version)
(output #f)
(path path))))
(item path))))
(_ #f))
opts)))
@ -932,7 +926,8 @@ (define (delete-generation number)
(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?)

4
tests/profiles.scm
View file

@ -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 @@ (define guile-2.0.9
(manifest-entry
(name "guile")
(version "2.0.9")
(path "/gnu/store/...")
(item "/gnu/store/...")
(output "out")))
(define guile-2.0.9:debug