02/05: environment: Add only the specified outputs of the dependencies.

[Ludovic Courtès]

civodul pushed a commit to branch wip-environment
in repository guix.

commit ee65d6c0b7622b6a9a6818b0e4f7aa08871552d0
Author: Ludovic Courtès <address@hidden>
Date:   Tue Jun 30 23:23:06 2015 +0200

    environment: Add only the specified outputs of the dependencies.
    
    Before that, 'guix environment guile' (for instance) would define 
environment
    variables that would refer to the "include" output of Bash, the "debug" 
output
    of libgc, etc., even though these are not listed as inputs in the recipe of
    'guile'.
    
    * guix/gexp.scm (lower-inputs): Export.
    * guix/scripts/environment.scm (evaluate-input-search-paths): Remove
      'derivations' parameter; add 'search-paths'.  Expect 'inputs' to be
      a list of tuples.  Adjust callers.
      (create-environment): Remove 'derivations' parameter; add 'search-paths'.
      (show-search-paths): Likewise.
      (package+propagated-inputs): New procedure.
      (packages->transitive-inputs, packages+propagated-inputs): Remove.
      (build-inputs): Expect INPUTS to be a list of derivation tuples.
      (guix-environment): Compute INPUTS using 'package+propagated-inputs',
      'package->bag', and 'bag-transitive-inputs'.  Move 'run-with-store' 
higher.
    * tests/guix-environment.sh: Add test with FINDUTILS-BOOT0.
---
 guix/gexp.scm                |    4 +-
 guix/scripts/environment.scm |  155 +++++++++++++++++++++---------------------
 tests/guix-environment.sh    |   20 ++++++
 3 files changed, 101 insertions(+), 78 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 0b5c43e..09b51b3 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -52,7 +52,9 @@
             compiled-modules
 
             define-gexp-compiler
-            gexp-compiler?))
+            gexp-compiler?
+
+            lower-inputs))
 
 ;;; Commentary:
 ;;;
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 007fde1..e2ac086 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -26,6 +26,7 @@
   #:use-module (guix search-paths)
   #:use-module (guix utils)
   #:use-module (guix monads)
+  #:use-module ((guix gexp) #:select (lower-inputs))
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
   #:use-module (ice-9 format)
@@ -36,20 +37,19 @@
   #:use-module (srfi srfi-98)
   #:export (guix-environment))
 
-(define (evaluate-input-search-paths inputs derivations)
-  "Evaluate the native search paths of INPUTS, a list of packages, of the
-outputs of DERIVATIONS, and return a list of search-path/value pairs."
-  (let ((directories (append-map (lambda (drv)
-                                   (map (match-lambda
-                                          ((_ . output)
-                                           (derivation-output-path output)))
-                                        (derivation-outputs drv)))
-                                 derivations))
-        (paths       (cons $PATH
-                           (delete-duplicates
-                            (append-map package-native-search-paths
-                                        inputs)))))
-    (evaluate-search-paths paths directories)))
+(define (evaluate-input-search-paths inputs search-paths)
+  "Evaluate SEARCH-PATHS, a list of search-path specifications, for the
+directories corresponding to INPUTS, a list of (DERIVATION) or (DERIVATION
+OUTPUT) tuples."
+  (let ((directories (map (match-lambda
+                            (((? derivation? drv))
+                             (derivation->output-path drv))
+                            (((? derivation? drv) output)
+                             (derivation->output-path drv output))
+                            (((? string? item))
+                             item))
+                          inputs)))
+    (evaluate-search-paths search-paths directories)))
 
 ;; Protect some env vars from purification.  Borrowed from nix-shell.
 (define %precious-variables
@@ -64,10 +64,11 @@ as 'HOME' and 'USER' are left untouched."
                       (((names . _) ...)
                        names)))))
 
-(define (create-environment inputs derivations pure?)
-  "Set the needed environment variables for all packages within INPUTS.  When
-PURE? is #t, unset the variables in the current environment.  Otherwise,
-augment existing enviroment variables with additional search paths."
+(define (create-environment inputs paths pure?)
+  "Set the environment variables specified by PATHS for all the packages
+within INPUTS.  When PURE? is #t, unset the variables in the current
+environment.  Otherwise, augment existing enviroment variables with additional
+search paths."
   (when pure? (purify-environment))
   (for-each (match-lambda
               ((($ <search-path-specification> variable _ separator) . value)
@@ -76,19 +77,24 @@ augment existing enviroment variables with additional 
search paths."
                          (if (and current (not pure?))
                              (string-append value separator current)
                              value)))))
-            (evaluate-input-search-paths inputs derivations)))
+            (evaluate-input-search-paths inputs paths)))
 
-(define (show-search-paths inputs derivations pure?)
-  "Display the needed search paths to build an environment that contains the
-packages within INPUTS.  When PURE? is #t, do not augment existing environment
-variables with additional search paths."
+(define (show-search-paths inputs search-paths pure?)
+  "Display SEARCH-PATHS applied to the packages specified by INPUTS, a list of
+ (DERIVATION) or (DERIVATION OUTPUT) tuples.  When PURE? is #t, do not augment
+existing environment variables with additional search paths."
   (for-each (match-lambda
               ((search-path . value)
                (display
                 (search-path-definition search-path value
                                         #:kind (if pure? 'exact 'prefix)))
                (newline)))
-            (evaluate-input-search-paths inputs derivations)))
+            (evaluate-input-search-paths inputs search-paths)))
+
+(define (package+propagated-inputs package)
+  "Return the union of PACKAGE and its transitive propagated inputs."
+  `((,(package-name package) ,package)
+    ,@(package-transitive-propagated-inputs package)))
 
 (define (show-help)
   (display (_ "Usage: guix environment [OPTION]... PACKAGE...
@@ -184,47 +190,23 @@ packages."
         (opt opt))
        opts))
 
-(define (packages->transitive-inputs packages)
-  "Return a list of the transitive inputs for all PACKAGES."
-  (define (transitive-inputs package)
-    (filter-map (match-lambda
-                 ((or (_ (? package? package))
-                      (_ (? package? package) _))
-                  package)
-                 (_ #f))
-                (bag-transitive-inputs
-                 (package->bag package))))
-  (delete-duplicates
-   (append-map transitive-inputs packages)))
-
-(define (packages+propagated-inputs packages)
-  "Return a list containing PACKAGES plus all of their propagated inputs."
-  (delete-duplicates
-   (append packages
-           (map (match-lambda
-                  ((or (_ (? package? package))
-                       (_ (? package? package) _))
-                   package)
-                  (_ #f))
-                (append-map package-transitive-propagated-inputs
-                            packages)))))
-
 (define (build-inputs inputs opts)
-  "Build the packages in INPUTS using the build options in OPTS."
+  "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION
+OUTPUT) tuples, using the build options in OPTS."
   (let ((substitutes? (assoc-ref opts 'substitutes?))
-        (dry-run? (assoc-ref opts 'dry-run?)))
-    (mlet* %store-monad ((drvs (sequence %store-monad
-                                         (map package->derivation inputs))))
-      (mbegin %store-monad
-        (show-what-to-build* drvs
-                             #:use-substitutes? substitutes?
-                             #:dry-run? dry-run?)
-        (if dry-run?
-            (return #f)
-            (mbegin %store-monad
-              (set-build-options-from-command-line* opts)
-              (built-derivations drvs)
-              (return drvs)))))))
+        (dry-run?     (assoc-ref opts 'dry-run?)))
+    (match inputs
+      (((derivations _ ...) ...)
+       (mbegin %store-monad
+         (show-what-to-build* derivations
+                              #:use-substitutes? substitutes?
+                              #:dry-run? dry-run?)
+         (if dry-run?
+             (return #f)
+             (mbegin %store-monad
+               (set-build-options-from-command-line* opts)
+               (built-derivations derivations)
+               (return derivations))))))))
 
 ;; Entry point.
 (define (guix-environment . args)
@@ -239,19 +221,38 @@ packages."
            (command  (assoc-ref opts 'exec))
            (packages (pick-all (options/resolve-packages opts) 'package))
            (inputs   (if ad-hoc?
-                         (packages+propagated-inputs packages)
-                         (packages->transitive-inputs packages))))
+                         (append-map package+propagated-inputs packages)
+                         (append-map (compose bag-transitive-inputs
+                                              package->bag)
+                                     packages)))
+           (paths    (delete-duplicates
+                      (cons $PATH
+                            (append-map (match-lambda
+                                          ((label (? package? p) _ ...)
+                                           (package-native-search-paths p))
+                                          (_
+                                           '()))
+                                        inputs))
+                      eq?)))
       (with-store store
-        (define drvs
-          (run-with-store store
+        (run-with-store store
+          (mlet %store-monad ((inputs (lower-inputs
+                                       (map (match-lambda
+                                              ((label item)
+                                               (list item))
+                                              ((label item output)
+                                               (list item output)))
+                                            inputs)
+                                       #:system (%current-system))))
             (mbegin %store-monad
-              (set-guile-for-build (default-guile))
-              (build-inputs inputs opts))))
-
-        (cond ((assoc-ref opts 'dry-run?)
-               #t)
-              ((assoc-ref opts 'search-paths)
-               (show-search-paths inputs drvs pure?))
-              (else
-               (create-environment inputs drvs pure?)
-               (system command)))))))
+              ;; First build INPUTS.  This is necessary even for
+              ;; --search-paths.
+              (build-inputs inputs opts)
+              (cond ((assoc-ref opts 'dry-run?)
+                     (return #t))
+                    ((assoc-ref opts 'search-paths)
+                     (show-search-paths inputs paths pure?)
+                     (return #t))
+                    (else
+                     (create-environment inputs paths pure?)
+                     (return (system command)))))))))))
diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh
index 3d92d22..d04e6a6 100644
--- a/tests/guix-environment.sh
+++ b/tests/guix-environment.sh
@@ -58,4 +58,24 @@ then
          --exec='echo $PATH $CPATH $LIBRARY_PATH' > "$tmpdir/b"
     ( . "$tmpdir/a" ; echo $PATH $CPATH $LIBRARY_PATH ) > "$tmpdir/c"
     cmp "$tmpdir/b" "$tmpdir/c"
+
+    rm "$tmpdir"/*
+
+    # Compute the build environment for the initial GNU Findutils.
+    guix environment -e '(@@ (gnu packages commencement) findutils-boot0)' \
+        --no-substitutes --search-paths --pure > "$tmpdir/a"
+
+    # Make sure the bootstrap binaries are all listed where they belong.
+    grep -E '^export PATH=.*-bootstrap-binaries-0/bin'      "$tmpdir/a"
+    grep -E '^export PATH=.*-make-boot0-[0-9.]+/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"
+
+    # The following test assumes 'make-boot0' has a "debug" output.
+    make_boot0_debug="`guix build -e '(@@ (gnu packages commencement) 
gnu-make-boot0)' | grep -e -debug`"
+    test "x$make_boot0_debug" != "x"
+
+    # Make sure the "debug" output is not listed.
+    if grep -E "$make_boot0_debug" "$tmpdir/a"; then false; else true; fi
 fi