ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-11 13:49:23 -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

94
guix/profiles.scm
View file

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