From a54c94a40d3d87c80034793795bf13fd7abf7a6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 26 Jul 2014 22:08:10 +0200 Subject: [PATCH] profiles: Switch to gexps. * guix/profiles.scm ()[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'. --- guix/profiles.scm | 94 +++++++++++++++++++--------------------- guix/scripts/package.scm | 35 +++++++-------- tests/profiles.scm | 4 +- 3 files changed, 62 insertions(+), 71 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 - (($ name version path output (deps ...)) - (list name version path output deps)))) + (($ name version output (? string? path) (deps ...)) + #~(#$name #$version #$output #$path #$deps)) + (($ name version output (? package? package) (deps ...)) + #~(#$name #$version #$output + (ungexp package (or output "out")) #$deps)))) (match 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 + (($ name version + output path deps (inputs ..1)) + inputs) + (($ 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)) + #~(begin + (use-modules (ice-9 pretty-print) + (guix build union)) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) + (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)))))) + (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)))))) - (build-expression->derivation store "profile" builder - #:inputs - (append-map (match-lambda - (($ name version - output path deps (inputs ..1)) - (map (cute lower-input store <>) - inputs)) - (($ 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)) + (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 - ((($ name version output path _) ..1) + ((($ 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 +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; 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