environment: Support package transformation options.

Fixes <https://bugs.gnu.org/33776>.
Reported by Adrien Guilbaud <adrien.guilbaud@inria.fr>.

* guix/scripts/environment.scm (show-help): Add call to
'show-transformation-options-help'.
(%options): Add %TRANSFORMATION-OPTIONS.
(options/resolve-packages): Add 'store' parameter.
[transform, package->manifest-entry*]: New procedures.
Use 'package->manifest-entry*' instead of 'package->manifest-entry'.
(guix-environment): Move definition of 'manifest' within 'with-store'.
* tests/guix-environment.sh: Add test.
This commit is contained in:
Ludovic Courtès 2018-12-17 22:47:44 +01:00 committed by Ludovic Courtès
parent bafcf1f32f
commit a93c160631
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 33 additions and 8 deletions

View file

@ -8350,7 +8350,8 @@ guix environment --container --share=$HOME=/exchange --ad-hoc guile -- guile
@command{guix environment} @command{guix environment}
also supports all of the common build options that @command{guix also supports all of the common build options that @command{guix
build} supports (@pxref{Common Build Options}). build} supports (@pxref{Common Build Options}) as well as package
transformation options (@pxref{Package Transformation Options}).
@node Invoking guix publish @node Invoking guix publish

View file

@ -162,6 +162,8 @@ (define (show-help)
(newline) (newline)
(show-build-options-help) (show-build-options-help)
(newline) (newline)
(show-transformation-options-help)
(newline)
(display (G_ " (display (G_ "
-h, --help display this help and exit")) -h, --help display this help and exit"))
(display (G_ " (display (G_ "
@ -261,7 +263,9 @@ (define %options
(option '("bootstrap") #f #f (option '("bootstrap") #f #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'bootstrap? #t result))) (alist-cons 'bootstrap? #t result)))
%standard-build-options))
(append %transformation-options
%standard-build-options)))
(define (pick-all alist key) (define (pick-all alist key)
"Return a list of values in ALIST associated with KEY." "Return a list of values in ALIST associated with KEY."
@ -274,7 +278,7 @@ (define same-key? (cut eq? key <>))
(_ memo))) (_ memo)))
'() alist)) '() alist))
(define (options/resolve-packages opts) (define (options/resolve-packages store opts)
"Return OPTS with package specification strings replaced by manifest entries "Return OPTS with package specification strings replaced by manifest entries
for the corresponding packages." for the corresponding packages."
(define (manifest-entry=? e1 e2) (define (manifest-entry=? e1 e2)
@ -282,15 +286,21 @@ (define (manifest-entry=? e1 e2)
(string=? (manifest-entry-output e1) (string=? (manifest-entry-output e1)
(manifest-entry-output e2)))) (manifest-entry-output e2))))
(define transform
(cut (options->transformation opts) store <>))
(define* (package->manifest-entry* package #:optional (output "out"))
(package->manifest-entry (transform package) output))
(define (packages->outputs packages mode) (define (packages->outputs packages mode)
(match packages (match packages
((? package? package) ((? package? package)
(if (eq? mode 'ad-hoc-package) (if (eq? mode 'ad-hoc-package)
(list (package->manifest-entry package)) (list (package->manifest-entry* package))
(package-environment-inputs package))) (package-environment-inputs package)))
(((? package? package) (? string? output)) (((? package? package) (? string? output))
(if (eq? mode 'ad-hoc-package) (if (eq? mode 'ad-hoc-package)
(list (package->manifest-entry package output)) (list (package->manifest-entry* package output))
(package-environment-inputs package))) (package-environment-inputs package)))
((lst ...) ((lst ...)
(append-map (cut packages->outputs <> mode) lst)))) (append-map (cut packages->outputs <> mode) lst))))
@ -301,7 +311,7 @@ (define (packages->outputs packages mode)
(('package 'ad-hoc-package (? string? spec)) (('package 'ad-hoc-package (? string? spec))
(let-values (((package output) (let-values (((package output)
(specification->package+output spec))) (specification->package+output spec)))
(list (package->manifest-entry package output)))) (list (package->manifest-entry* package output))))
(('package 'package (? string? spec)) (('package 'package (? string? spec))
(package-environment-inputs (package-environment-inputs
(specification->package+output spec))) (specification->package+output spec)))
@ -654,7 +664,6 @@ (define (guix-environment . args)
;; within the container. ;; within the container.
'("/bin/sh") '("/bin/sh")
(list %default-shell)))) (list %default-shell))))
(manifest (options/resolve-packages opts))
(mappings (pick-all opts 'file-system-mapping))) (mappings (pick-all opts 'file-system-mapping)))
(when container? (assert-container-features)) (when container? (assert-container-features))
@ -666,6 +675,9 @@ (define (guix-environment . args)
(with-store store (with-store store
(with-status-report print-build-event (with-status-report print-build-event
(define manifest
(options/resolve-packages store opts))
(set-build-options-from-command-line store opts) (set-build-options-from-command-line store opts)
;; Use the bootstrap Guile when requested. ;; Use the bootstrap Guile when requested.

View file

@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU # GNU Guix --- Functional package management for GNU
# Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> # Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
# #
# This file is part of GNU Guix. # This file is part of GNU Guix.
# #
@ -118,6 +118,18 @@ fi
# in its profile (e.g., for 'gzip'), but we have to accept them. # in its profile (e.g., for 'gzip'), but we have to accept them.
guix environment guix --bootstrap -n guix environment guix --bootstrap -n
# Try program transformation options.
mkdir "$tmpdir/emacs-36.8"
drv="`guix environment --ad-hoc emacs -n 2>&1 | grep 'emacs.*\.drv'`"
transformed_drv="`guix environment --ad-hoc emacs --with-source="$tmpdir/emacs-36.8" -n 2>&1 | grep 'emacs.*\.drv'`"
test -n "$drv"
test "$drv" != "$transformed_drv"
case "$transformed_drv" in
*-emacs-36.8.drv) true;;
*) false;;
esac
rmdir "$tmpdir/emacs-36.8"
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
then then
# Compute the build environment for the initial GNU Make. # Compute the build environment for the initial GNU Make.