04/06: Callers of 'build-derivations' & co. now honor its result.

[Ludovic Courtès]

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

commit 0c8491cbbead8d04b84714ee4f970f1f1c7be352
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jan 9 23:06:54 2017 +0100

    Callers of 'build-derivations' & co. now honor its result.
    
    * guix/profiles.scm (link-to-empty-profile): Use the result of
    'build-derivations' instead of calling 'derivation->output-path'.
    * guix/scripts.scm (build-package): Likewise, and use 'format' directly
    instead of 'show-derivation-outputs'.
    (build-package-source): Likewise.
    * guix/scripts/archive.scm (export-from-store): Use result of
    'build-derivations'.
    * guix/scripts/build.scm (guix-build): Likewise.  Use 'format' instead
    of 'show-derivation-outputs'.
    * guix/scripts/copy.scm (send-to-remote-host): Use result of
    'build-derivations'.
    * guix/scripts/package.scm (build-and-use-profile): Likewise.
    * guix/upstream.scm (download-tarball): Likewise.
    * guix/scripts/system.scm (reinstall-grub): Likewise.
    (perform-action): Use result of 'maybe-build'.
---
 guix/profiles.scm        |    5 ++---
 guix/scripts.scm         |   34 ++++++++++++++++++++--------------
 guix/scripts/archive.scm |   36 ++++++++++++++++++------------------
 guix/scripts/build.scm   |   14 +++++---------
 guix/scripts/copy.scm    |   19 ++++++++++---------
 guix/scripts/package.scm |   31 ++++++++++++++++---------------
 guix/scripts/system.scm  |   31 +++++++++++++++----------------
 guix/upstream.scm        |    6 ++----
 8 files changed, 88 insertions(+), 88 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index e7707b6..58df449 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2014, 2016 Alex Kost <address@hidden>
 ;;; Copyright © 2015 Mark H Weaver <address@hidden>
@@ -1120,8 +1120,7 @@ that fails."
   (let* ((drv  (run-with-store store
                  (profile-derivation (manifest '())
                                      #:locales? #f)))
-         (prof (derivation->output-path drv "out")))
-    (build-derivations store (list drv))
+         (prof (build-derivations store (list drv))))
     (switch-symlinks generation prof)))
 
 (define (switch-to-generation profile number)
diff --git a/guix/scripts.scm b/guix/scripts.scm
index bbee50b..e4e5322 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2014 Deck Pickard <address@hidden>
 ;;; Copyright © 2015, 2016 Alex Kost <address@hidden>
 ;;;
@@ -29,6 +29,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:export (args-fold*
             parse-command-line
             maybe-build
@@ -90,7 +91,8 @@ parameter of 'args-fold'."
 (define* (maybe-build drvs
                       #:key dry-run? use-substitutes?)
   "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
-true."
+true.  Return #f when DRY-RUN? is true, and the list of store items actually
+built otherwise."
   (with-monad %store-monad
     (>>= (show-what-to-build* drvs
                               #:dry-run? dry-run?
@@ -112,12 +114,14 @@ Show what and how will/would be built."
            (strip-keyword-arguments '(#:dry-run?) build-options))
     (mlet %store-monad ((derivation (package->derivation
                                      package #:graft? (and (not dry-run?)
-                                                           grafting?))))
-      (mbegin %store-monad
-        (maybe-build (list derivation)
-                     #:use-substitutes? use-substitutes?
-                     #:dry-run? dry-run?)
-        (return (show-derivation-outputs derivation))))))
+                                                           grafting?)))
+                        (items      (maybe-build (list derivation)
+                                                 #:use-substitutes?
+                                                 use-substitutes?
+                                                 #:dry-run? dry-run?)))
+      (unless dry-run?
+        (format #t "~{~a~%~}" items))
+      (return (or dry-run? items)))))
 
 (define* (build-package-source package
                                #:key dry-run? (use-substitutes? #t)
@@ -129,11 +133,13 @@ Show what and how will/would be built."
            #:use-substitutes? use-substitutes?
            (strip-keyword-arguments '(#:dry-run?) build-options))
     (mlet %store-monad ((derivation (origin->derivation
-                                     (package-source package))))
-      (mbegin %store-monad
-        (maybe-build (list derivation)
-                     #:use-substitutes? use-substitutes?
-                     #:dry-run? dry-run?)
-        (return (show-derivation-outputs derivation))))))
+                                     (package-source package)))
+                        (items      (maybe-build (list derivation)
+                                                 #:use-substitutes?
+                                                 use-substitutes?
+                                                 #:dry-run? dry-run?)))
+      (unless dry-run?
+        (format #t "~{~a~%~}" items))
+      (return (or dry-run? items)))))
 
 ;;; scripts.scm ends here
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 9e49c53..bd64d9f 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -256,24 +256,24 @@ resulting archive to the standard output port."
                         #:use-substitutes? (assoc-ref opts 'substitutes?)
                         #:dry-run? (assoc-ref opts 'dry-run?))
 
-    (if (or (assoc-ref opts 'dry-run?)
-            (build-derivations store drv))
-        (match (assoc-ref opts 'format)
-          ("nar"
-           (export-paths store files (current-output-port)
-                         #:recursive? (assoc-ref opts 'export-recursive?)))
-          ("docker"
-           (match files
-             ((file)
-              (let ((system (assoc-ref opts 'system)))
-                (format #t "~a\n"
-                        (build-docker-image file #:system system))))
-             (_
-              ;; TODO: Remove this restriction.
-              (leave (_ "only a single item can be exported to Docker~%")))))
-          (format
-           (leave (_ "~a: unknown archive format~%") format)))
-        (leave (_ "unable to export the given packages~%")))))
+    (let ((files (if (assoc-ref opts 'dry-run?)
+                     files
+                     (build-derivations store drv))))
+      (match (assoc-ref opts 'format)
+        ("nar"
+         (export-paths store files (current-output-port)
+                       #:recursive? (assoc-ref opts 'export-recursive?)))
+        ("docker"
+         (match files
+           ((file)
+            (let ((system (assoc-ref opts 'system)))
+              (format #t "~a\n"
+                      (build-docker-image file #:system system))))
+           (_
+            ;; TODO: Remove this restriction.
+            (leave (_ "only a single item can be exported to Docker~%")))))
+        (format
+         (leave (_ "~a: unknown archive format~%") format))))))
 
 (define (generate-key-pair parameters)
   "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index ccb4c27..6c57a6b 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2013 Mark H Weaver <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -726,11 +726,7 @@ needed."
                              (map (compose list derivation-file-name) drv)
                              roots))
                   ((not (assoc-ref opts 'dry-run?))
-                   (and (build-derivations store drv mode)
-                        (for-each show-derivation-outputs drv)
-                        (for-each (cut register-root store <> <>)
-                                  (map (lambda (drv)
-                                         (map cdr
-                                              (derivation->output-paths drv)))
-                                       drv)
-                                  roots))))))))))
+                   (let ((outputs (build-derivations store drv mode)))
+                     (format #t "~{~a~%~}" outputs)
+                     (for-each (cut register-root store <> <>)
+                               outputs roots))))))))))
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index 9ae204e..e566a05 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -112,14 +112,15 @@ package names, build the underlying packages before 
sending them."
                           #:use-substitutes? (assoc-ref opts 'substitutes?)
                           #:dry-run? (assoc-ref opts 'dry-run?))
 
-      (and (or (assoc-ref opts 'dry-run?)
-               (build-derivations local drv))
-           (let* ((session (open-ssh-session host #:user user #:port port))
-                  (sent    (send-files local items
-                                       (connect-to-remote-daemon session)
-                                       #:recursive? #t)))
-             (format #t "~{~a~%~}" sent)
-             sent)))))
+      (let ((items   (if (assoc-ref opts 'dry-run?)
+                         items
+                         (build-derivations local drv)))
+            (session (open-ssh-session host #:user user #:port port))
+            (sent    (send-files local items
+                                 (connect-to-remote-daemon session)
+                                 #:recursive? #t)))
+        (format #t "~{~a~%~}" sent)
+        sent))))
 
 (define (retrieve-from-remote-host source opts)
   "Retrieve ITEMS from SOURCE."
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 90e7fa2..70e68ef 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2013, 2015 Mark H Weaver <address@hidden>
 ;;; Copyright © 2014, 2016 Alex Kost <address@hidden>
@@ -207,19 +207,20 @@ specified in MANIFEST, a manifest object."
                         #:use-substitutes? use-substitutes?
                         #:dry-run? dry-run?)
 
-    (cond
-     (dry-run? #t)
-     ((and (file-exists? profile)
-           (and=> (readlink* profile) (cut string=? prof <>)))
-      (format (current-error-port) (_ "nothing to be done~%")))
-     (else
-      (let* ((number (generation-number profile))
-
-             ;; Always use NUMBER + 1 for the new profile, possibly
-             ;; overwriting a "previous future generation".
-             (name   (generation-file-name profile (+ 1 number))))
-        (and (build-derivations store (list prof-drv))
-             (let* ((entries (manifest-entries manifest))
+    (or dry-run?
+        (match (build-derivations store (list prof-drv))
+          ((prof)
+           (cond
+            ((and (file-exists? profile)
+                  (and=> (readlink* profile) (cut string=? prof <>)))
+             (format (current-error-port) (_ "nothing to be done~%")))
+            (else
+             (let* ((number (generation-number profile))
+
+                    ;; Always use NUMBER + 1 for the new profile, possibly
+                    ;; overwriting a "previous future generation".
+                    (name   (generation-file-name profile (+ 1 number)))
+                    (entries (manifest-entries manifest))
                     (count   (length entries)))
                (switch-symlinks name prof)
                (switch-symlinks profile name)
@@ -230,7 +231,7 @@ specified in MANIFEST, a manifest object."
                               count)
                        count)
                (display-search-paths entries (list profile)
-                                     #:kind 'prefix))))))))
+                                     #:kind 'prefix)))))))))
 
 
 ;;;
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 144a7fd..ee3334d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Alex Kost <address@hidden>
 ;;; Copyright © 2016 Chris Marusich <address@hidden>
 ;;;
@@ -445,20 +445,21 @@ open connection to the store."
                                               entries
                                               #:old-entries old-entries))))
     (show-what-to-build store (list grub.cfg))
-    (build-derivations store (list grub.cfg))
+
     ;; This is basically the same as install-grub*, but for now we avoid
     ;; re-installing the GRUB boot loader itself onto a device, mainly because
     ;; we don't in general have access to the same version of the GRUB package
     ;; which was used when installing this other system generation.
-    (let* ((grub.cfg-path (derivation->output-path grub.cfg))
-           (gc-root (string-append %gc-roots-directory "/grub.cfg"))
-           (temp-gc-root (string-append gc-root ".new")))
-      (switch-symlinks temp-gc-root grub.cfg-path)
-      (unless (false-if-exception (install-grub-config grub.cfg-path "/"))
-        (delete-file temp-gc-root)
-        (leave (_ "failed to re-install GRUB configuration file: '~a'~%")
-               grub.cfg-path))
-      (rename-file temp-gc-root gc-root))))
+    (match (build-derivations store (list grub.cfg))
+      ((grub.cfg-path)
+       (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg"))
+              (temp-gc-root (string-append gc-root ".new")))
+         (switch-symlinks temp-gc-root grub.cfg-path)
+         (unless (false-if-exception (install-grub-config grub.cfg-path "/"))
+           (delete-file temp-gc-root)
+           (leave (_ "failed to re-install GRUB configuration file: '~a'~%")
+                  grub.cfg-path))
+         (rename-file temp-gc-root gc-root))))))
 
 
 ;;;
@@ -630,17 +631,15 @@ building anything."
                           (list sys grub.cfg grub)
                           (list sys grub.cfg))
                       (list sys)))
-       (%         (if derivations-only?
-                      (return (for-each (compose println derivation-file-name)
-                                        drvs))
+       (results   (if derivations-only?
+                      (return (map derivation-file-name drvs))
                       (maybe-build drvs #:dry-run? dry-run?
                                    #:use-substitutes? use-substitutes?))))
 
     (if (or dry-run? derivations-only?)
         (return #f)
         (begin
-          (for-each (compose println derivation->output-path)
-                    drvs)
+          (for-each println results)
 
           ;; Make sure GRUB is accessible.
           (when grub?
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 2334c4c..f32f7de 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2015 Alex Kost <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -201,9 +201,7 @@ values: 'interactive' (default), 'always', and 'never'."
                          (run-with-store store
                            (mlet %store-monad ((drv (uncompressed-tarball
                                                      (basename url) tarball)))
-                             (mbegin %store-monad
-                               (built-derivations (list drv))
-                               (return (derivation->output-path drv)))))))
+                             (built-derivations (list drv))))))
 
                (ret  (gnupg-verify* sig data #:key-download key-download)))
           (if ret