scripts: environment: Allow mixing regular and ad-hoc packages.

This patch changes the --ad-hoc flag to be positional.  That is, the
packages that appear before --ad-hoc are interpreted as packages whose
inputs should be in the environment; the packages that appear after are
interpreted as packages to be directly added to the environment.

* guix/scripts/environment.scm (tag-package-arg, compact): New
  procedures.
  (%options): Tweak the handlers for --load and --expression options.
  (options/resolve-packages): Preserve package mode tag.
  (parse-args): Tweak argument handler to use package tagging procedure.
  (guix-environment): Apply ad-hoc behavior on a per package basis.
* tests/guix-environment.sh: Add test.
* doc/guix.texi ("invoking guix environment"): Document new behavior of
  --ad-hoc.

3 files changed, 85 insertions, 34 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 844f9fa75d..6b6e937c6d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4699,6 +4699,20 @@ NumPy:
 guix environment --ad-hoc python2-numpy python-2.7 -- python
 @end example
 
+Furthermore, one might want the dependencies of a package and also some
+additional packages that are not build-time or runtime dependencies, but
+are useful when developing nonetheless.  Because of this, the
+@code{--ad-hoc} flag is positional.  Packages appearing before
+@code{--ad-hoc} are interpreted as packages whose dependencies will be
+added to the environment.  Packages appearing after are interpreted as
+packages that will be added to the environment directly.  For example,
+the following command creates a Guix development environment that
+additionally includes Git and strace:
+
+@example
+guix environment guix --ad-hoc git strace
+@end example
+
 Sometimes it is desirable to isolate the environment as much as
 possible, for maximal purity and reproducibility.  In particular, when
 using Guix on a host distro that is not GuixSD, it is desirable to
@@ -4759,6 +4773,12 @@ Note that this example implicitly asks for the default output of
 specific output---e.g., @code{glib:bin} asks for the @code{bin} output
 of @code{glib} (@pxref{Packages with Multiple Outputs}).
 
+This option may be composed with the default behavior of @command{guix
+environment}.  Packages appearing before @code{--ad-hoc} are interpreted
+as packages whose dependencies will be added to the environment, the
+default behavior.  Packages appearing after are interpreted as packages
+that will be added to the environment directly.
+
 @item --pure
 Unset existing environment variables when building the new environment.
 This has the effect of creating an environment in which search paths
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 1d21a768dc..188838574f 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -166,6 +166,16 @@ COMMAND or an interactive shell in that environment.\n"))
     (max-silent-time . 3600)
     (verbosity . 0)))
 
+(define (tag-package-arg opts arg)
+  "Return a two-element list with the form (TAG ARG) that tags ARG with either
+'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise."
+  ;; Normally, the transitive inputs to a package are added to an environment,
+  ;; but the ad-hoc? flag changes the meaning of a package argument such that
+  ;; the package itself is added to the environment instead.
+  (if (assoc-ref opts 'ad-hoc?)
+      `(ad-hoc-package ,arg)
+      `(package ,arg)))
+
 (define %options
   ;; Specification of the command-line options.
   (cons* (option '(#\h "help") #f #f
@@ -186,10 +196,14 @@ COMMAND or an interactive shell in that environment.\n"))
                    (alist-cons 'search-paths #t result)))
          (option '(#\l "load") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'load arg result)))
+                   (alist-cons 'load
+                               (tag-package-arg result arg)
+                               result)))
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'expression arg result)))
+                   (alist-cons 'expression
+                               (tag-package-arg result arg)
+                               result)))
          (option '("ad-hoc") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'ad-hoc? #t result)))
@@ -232,29 +246,34 @@ COMMAND or an interactive shell in that environment.\n"))
             (_ memo)))
         '() alist))
 
+(define (compact lst)
+  "Remove all #f elements from LST."
+  (filter identity lst))
+
 (define (options/resolve-packages opts)
   "Return OPTS with package specification strings replaced by actual
 packages."
-  (append-map (match-lambda
-                (('package . (? string? spec))
-                 (let-values (((package output)
-                               (specification->package+output spec)))
-                   `((package ,package ,output))))
-                (('expression . str)
-                 ;; Add all the outputs of the package STR evaluates to.
-                 (match (read/eval str)
-                   ((? package? package)
+  (compact
+   (append-map (match-lambda
+                 (('package mode (? string? spec))
+                  (let-values (((package output)
+                                (specification->package+output spec)))
+                    (list (list mode package output))))
+                 (('expression mode str)
+                  ;; Add all the outputs of the package STR evaluates to.
+                  (match (read/eval str)
+                    ((? package? package)
+                     (map (lambda (output)
+                            (list mode package output))
+                          (package-outputs package)))))
+                 (('load mode file)
+                  ;; Add all the outputs of the package defined in FILE.
+                  (let ((package (load* file (make-user-module '()))))
                     (map (lambda (output)
-                           `(package ,package ,output))
-                         (package-outputs package)))))
-                (('load . file)
-                 ;; Add all the outputs of the package defined in FILE.
-                 (let ((package (load* file (make-user-module '()))))
-                   (map (lambda (output)
-                          `(package ,package ,output))
-                        (package-outputs package))))
-                (opt (list opt)))
-              opts))
+                           (list mode package output))
+                         (package-outputs package))))
+                 (_ '(#f)))
+               opts)))
 
 (define (build-inputs inputs opts)
   "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION
@@ -402,7 +421,7 @@ Otherwise, return the derivation for the Bash package."
 (define (parse-args args)
   "Parse the list of command line arguments ARGS."
   (define (handle-argument arg result)
-    (alist-cons 'package arg result))
+    (alist-cons 'package (tag-package-arg result arg) result))
 
   ;; The '--' token is used to separate the command to run from the rest of
   ;; the operands.
@@ -420,22 +439,20 @@ Otherwise, return the derivation for the Bash package."
            (pure?      (assoc-ref opts 'pure))
            (container? (assoc-ref opts 'container?))
            (network?   (assoc-ref opts 'network?))
-           (ad-hoc?    (assoc-ref opts 'ad-hoc?))
            (bootstrap? (assoc-ref opts 'bootstrap?))
            (system     (assoc-ref opts 'system))
            (command    (assoc-ref opts 'exec))
-           (packages   (pick-all (options/resolve-packages opts) 'package))
+           (packages   (options/resolve-packages opts))
            (mappings   (pick-all opts 'file-system-mapping))
-           (inputs     (if ad-hoc?
-                           (append-map (match-lambda
-                                        ((package output)
-                                         (package+propagated-inputs package
-                                                                    output)))
-                                       packages)
-                           (append-map (compose bag-transitive-inputs
-                                                package->bag
-                                                first)
-                                       packages)))
+           (inputs     (delete-duplicates
+                        (append-map (match-lambda
+                                      (('ad-hoc-package package output)
+                                       (package+propagated-inputs package
+                                                                  output))
+                                      (('package package output)
+                                       (bag-transitive-inputs
+                                        (package->bag package))))
+                                    packages)))
            (paths      (delete-duplicates
                         (cons $PATH
                               (append-map (match-lambda
diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh
index f91c78a801..49b3b1ccc3 100644
--- a/tests/guix-environment.sh
+++ b/tests/guix-environment.sh
@@ -97,4 +97,18 @@ then
 
     # Make sure the "debug" output is not listed.
     if grep -E "$make_boot0_debug" "$tmpdir/a"; then false; else true; fi
+
+    # Compute the build environment for the initial GNU Make, but add in the
+    # bootstrap Guile as an ad-hoc addition.
+    guix environment -e '(@@ (gnu packages commencement) gnu-make-boot0)' \
+         --ad-hoc guile-bootstrap --no-substitutes --search-paths \
+         --pure > "$tmpdir/a"
+
+    # Make sure the bootstrap binaries are all listed where they belong.
+    cat $tmpdir/a
+    grep -E '^export PATH=.*-bootstrap-binaries-0/bin'      "$tmpdir/a"
+    grep -E '^export PATH=.*-guile-bootstrap-2.0/bin'       "$tmpdir/a"
+    grep -E '^export CPATH=.*-gcc-bootstrap-0/include'      "$tmpdir/a"
+    grep -E '^export CPATH=.*-glibc-bootstrap-0/include'    "$tmpdir/a"
+    grep -E '^export LIBRARY_PATH=.*-glibc-bootstrap-0/lib' "$tmpdir/a"
 fi