[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
04/06: Callers of 'build-derivations' & co. now honor its result.
|
From: |
Ludovic Courtès |
|
Subject: |
04/06: Callers of 'build-derivations' & co. now honor its result. |
|
Date: |
Mon, 9 Jan 2017 22:33:56 +0000 (UTC) |
civodul pushed a commit to branch wip-gexp-grafts
in repository guix.
commit 74c23da857c17d43d73e7358117c69a7b2719d51
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 | 11 ++++++-----
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, 76 insertions(+), 75 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 7e43235..5fee8e8 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.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>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -244,10 +244,11 @@ 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))
- (export-paths store files (current-output-port)
- #:recursive? (assoc-ref opts 'export-recursive?))
+ (if (let ((files (if (assoc-ref opts 'dry-run?)
+ files
+ (build-derivations store drv))))
+ (export-paths store files (current-output-port)
+ #:recursive? (assoc-ref opts 'export-recursive?)))
(leave (_ "unable to export the given packages~%")))))
(define (generate-key-pair parameters)
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
- branch wip-gexp-grafts created (now f2abcdf), Ludovic Courtès, 2017/01/09
- 01/06: packages: Factorize computation of the replacement graft., Ludovic Courtès, 2017/01/09
- 03/06: DRAFT store: Add support for build continuations., Ludovic Courtès, 2017/01/09
- 05/06: ui: Remove 'show-derivation-outputs'., Ludovic Courtès, 2017/01/09
- 02/06: gexp: Compilers can now provide a procedure returning applicable grafts., Ludovic Courtès, 2017/01/09
- 06/06: DRAFT gexp: Turn grafting into a build continuation., Ludovic Courtès, 2017/01/09
- 04/06: Callers of 'build-derivations' & co. now honor its result.,
Ludovic Courtès <=