From a93c1606312e41ffe509977502ce6055f40bc629 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludovic.courtes@inria.fr>
Date: Mon, 17 Dec 2018 22:47:44 +0100
Subject: [PATCH] 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.
---
 doc/guix.texi                |  3 ++-
 guix/scripts/environment.scm | 24 ++++++++++++++++++------
 tests/guix-environment.sh    | 14 +++++++++++++-
 3 files changed, 33 insertions(+), 8 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 1c26dc5a89..3ee65116b6 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8350,7 +8350,8 @@ guix environment --container --share=$HOME=/exchange --ad-hoc guile -- guile
 
 @command{guix environment}
 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
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 5965e3426e..7733fbcae4 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -162,6 +162,8 @@ (define (show-help)
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
@@ -261,7 +263,9 @@ (define %options
          (option '("bootstrap") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'bootstrap? #t result)))
-         %standard-build-options))
+
+         (append %transformation-options
+                 %standard-build-options)))
 
 (define (pick-all alist key)
   "Return a list of values in ALIST associated with KEY."
@@ -274,7 +278,7 @@ (define same-key? (cut eq? key <>))
             (_ memo)))
         '() alist))
 
-(define (options/resolve-packages opts)
+(define (options/resolve-packages store opts)
   "Return OPTS with package specification strings replaced by manifest entries
 for the corresponding packages."
   (define (manifest-entry=? e1 e2)
@@ -282,15 +286,21 @@ (define (manifest-entry=? e1 e2)
          (string=? (manifest-entry-output e1)
                    (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)
     (match packages
       ((? package? package)
        (if (eq? mode 'ad-hoc-package)
-           (list (package->manifest-entry package))
+           (list (package->manifest-entry* package))
            (package-environment-inputs package)))
       (((? package? package) (? string? output))
        (if (eq? mode 'ad-hoc-package)
-           (list (package->manifest-entry package output))
+           (list (package->manifest-entry* package output))
            (package-environment-inputs package)))
       ((lst ...)
        (append-map (cut packages->outputs <> mode) lst))))
@@ -301,7 +311,7 @@ (define (packages->outputs packages mode)
                   (('package 'ad-hoc-package (? string? spec))
                    (let-values (((package output)
                                  (specification->package+output spec)))
-                     (list (package->manifest-entry package output))))
+                     (list (package->manifest-entry* package output))))
                   (('package 'package (? string? spec))
                    (package-environment-inputs
                     (specification->package+output spec)))
@@ -654,7 +664,6 @@ (define (guix-environment . args)
                                ;; within the container.
                                '("/bin/sh")
                                (list %default-shell))))
-           (manifest   (options/resolve-packages opts))
            (mappings   (pick-all opts 'file-system-mapping)))
 
       (when container? (assert-container-features))
@@ -666,6 +675,9 @@ (define (guix-environment . args)
 
       (with-store store
         (with-status-report print-build-event
+          (define manifest
+            (options/resolve-packages store opts))
+
           (set-build-options-from-command-line store opts)
 
           ;; Use the bootstrap Guile when requested.
diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh
index b44aca099d..30b21028aa 100644
--- a/tests/guix-environment.sh
+++ b/tests/guix-environment.sh
@@ -1,5 +1,5 @@
 # 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.
 #
@@ -118,6 +118,18 @@ fi
 # in its profile (e.g., for 'gzip'), but we have to accept them.
 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
 then
     # Compute the build environment for the initial GNU Make.