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

[David Thompson]

Thanks to Leo for bringing up this missing feature on IRC.  I've been
meaning to implement this for awhile but lacked motivation. ;)

With this patch, you can freely compose packages whose inputs should be
in the environment with ad-hoc packages that should be added to the
environment directly.  For example, here's how to create a Guix
development environment that additionally has strace:

    guix environment guix --ad-hoc strace

The --load and --expression options are --ad-hoc aware as well.  Yay,
composability!

>From 6a1c0b03a0083cc521be5c28a438ed5ecafd2b9d Mon Sep 17 00:00:00 2001
From: David Thompson <address@hidden>
Date: Sun, 25 Oct 2015 22:33:33 -0400
Subject: [PATCH] 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.
* doc/guix.texi ("invoking guix environment"): Document new behavior of
  --ad-hoc.
---
 doc/guix.texi                | 20 +++++++++++
 guix/scripts/environment.scm | 85 ++++++++++++++++++++++++++------------------
 2 files changed, 71 insertions(+), 34 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7715b72..dfd377c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4681,6 +4681,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
address@hidden flag is positional.  Packages appearing before
address@hidden 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:
+
address@hidden
+guix environment guix --ad-hoc git strace
address@hidden 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
@@ -4741,6 +4755,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 1d21a76..1888385 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
-- 
2.5.0

-- 
David Thompson
GPG Key: 0FF1D807