all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: "Ludovic Courtès" <ludo@gnu.org>
To: 27162@debbugs.gnu.org
Subject: bug#27162: [PATCH 2/6] derivations: 'derivation-prerequisites-to-build' returns <substitutable>.
Date: Wed, 31 May 2017 15:51:55 +0200	[thread overview]
Message-ID: <20170531135159.8186-2-ludo@gnu.org> (raw)
In-Reply-To: <20170531135159.8186-1-ludo@gnu.org>

* guix/derivations.scm (derivation-prerequisites-to-build): Rename
 #:substitutable? to #:substitutable-info.
[derivation-substitutable?]: Rename to...
[derivation-substitutable-info]: ... this.  Return a list of <substitutable>.
Second return value is now a list of <substitutable> instead of a list
of strings.
* guix/ui.scm (show-what-to-build)[substitutable?]: Rename to...
[substitutable-info]: ... this.
Adjust to new 'derivation-prerequisites-to-build' return value type.
* tests/derivations.scm ("derivation-prerequisites-to-build and
substitutes"): Adjust.
("derivation-prerequisites-to-build and substitutes, local build"):
Likewise.
---
 guix/derivations.scm  | 31 ++++++++++++++++++-------------
 guix/ui.scm           | 25 +++++++++++++++----------
 tests/derivations.scm |  6 +++---
 3 files changed, 36 insertions(+), 26 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 5e457f189..b9ad9c9e8 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -334,13 +334,13 @@ substituter many times."
                                             (mode (build-mode normal))
                                             (outputs
                                              (derivation-output-names drv))
-                                            (substitutable?
+                                            (substitutable-info
                                              (substitution-oracle store
                                                                   (list drv)
                                                                   #:mode mode)))
   "Return two values: the list of derivation-inputs required to build the
 OUTPUTS of DRV and not already available in STORE, recursively, and the list
-of required store paths that can be substituted.  SUBSTITUTABLE? must be a
+of required store paths that can be substituted.  SUBSTITUTABLE-INFO must be a
 one-argument procedure similar to that returned by 'substitution-oracle'."
   (define built?
     (cut valid-path? store <>))
@@ -351,7 +351,7 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
   (define input-substitutable?
     ;; Return true if and only if all of SUB-DRVS are subsitutable.  If at
     ;; least one is missing, then everything must be rebuilt.
-    (compose (cut every substitutable? <>) derivation-input-output-paths))
+    (compose (cut every substitutable-info <>) derivation-input-output-paths))
 
   (define (derivation-built? drv* sub-drvs)
     ;; In 'check' mode, assume that DRV is not built.
@@ -359,20 +359,24 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
                    (eq? drv* drv)))
          (every built? (derivation-output-paths drv* sub-drvs))))
 
-  (define (derivation-substitutable? drv sub-drvs)
+  (define (derivation-substitutable-info drv sub-drvs)
     (and (substitutable-derivation? drv)
-         (every substitutable? (derivation-output-paths drv sub-drvs))))
+         (let ((info (filter-map substitutable-info
+                                 (derivation-output-paths drv sub-drvs))))
+           (and (= (length info) (length sub-drvs))
+                info))))
 
   (let loop ((drv        drv)
              (sub-drvs   outputs)
-             (build      '())
-             (substitute '()))
+             (build      '())                     ;list of <derivation-input>
+             (substitute '()))                    ;list of <substitutable>
     (cond ((derivation-built? drv sub-drvs)
            (values build substitute))
-          ((derivation-substitutable? drv sub-drvs)
-           (values build
-                   (append (derivation-output-paths drv sub-drvs)
-                           substitute)))
+          ((derivation-substitutable-info drv sub-drvs)
+           =>
+           (lambda (substitutables)
+             (values build
+                     (append substitutables substitute))))
           (else
            (let ((build  (if (substitutable-derivation? drv)
                              build
@@ -389,8 +393,9 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
                     (append (append-map (lambda (input)
                                           (if (and (not (input-built? input))
                                                    (input-substitutable? input))
-                                              (derivation-input-output-paths
-                                               input)
+                                              (map substitutable-info
+                                                   (derivation-input-output-paths
+                                                    input))
                                               '()))
                                         (derivation-inputs drv))
                             substitute)
diff --git a/guix/ui.scm b/guix/ui.scm
index 9e0fa26d1..9b6464896 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -588,7 +588,7 @@ error."
 derivations listed in DRV using MODE, a 'build-mode' value.  Return #t if
 there's something to build, #f otherwise.  When USE-SUBSTITUTES?, check and
 report what is prerequisites are available for download."
-  (define substitutable?
+  (define substitutable-info
     ;; Call 'substitutation-oracle' upfront so we don't end up launching the
     ;; substituter many times.  This makes a big difference, especially when
     ;; DRV is a long list as is the case with 'guix environment'.
@@ -600,7 +600,7 @@ report what is prerequisites are available for download."
     (or (null? (derivation-outputs drv))
         (let ((out (derivation->output-path drv))) ;XXX: assume "out" exists
           (or (valid-path? store out)
-              (substitutable? out)))))
+              (substitutable-info out)))))
 
   (let*-values (((build download)
                  (fold2 (lambda (drv build download)
@@ -608,7 +608,8 @@ report what is prerequisites are available for download."
                                         (derivation-prerequisites-to-build
                                          store drv
                                          #:mode mode
-                                         #:substitutable? substitutable?)))
+                                         #:substitutable-info
+                                         substitutable-info)))
                             (values (append b build)
                                     (append d download))))
                         '() '()
@@ -622,11 +623,13 @@ report what is prerequisites are available for download."
                  (if use-substitutes?
                      (delete-duplicates
                       (append download
-                              (remove (cut valid-path? store <>)
-                                      (append-map
-                                       substitutable-references
-                                       (substitutable-path-info store
-                                                                download)))))
+                              (filter-map (lambda (item)
+                                            (if (valid-path? store item)
+                                                #f
+                                                (substitutable-info item)))
+                                          (append-map
+                                           substitutable-references
+                                           download))))
                      download)))
     ;; TODO: Show the installed size of DOWNLOAD.
     (if dry-run?
@@ -640,7 +643,8 @@ report what is prerequisites are available for download."
                   (N_ "~:[The following file would be downloaded:~%~{   ~a~%~}~;~]"
                       "~:[The following files would be downloaded:~%~{   ~a~%~}~;~]"
                       (length download))
-                  (null? download) download))
+                  (null? download)
+                  (map substitutable-path download)))
         (begin
           (format (current-error-port)
                   (N_ "~:[The following derivation will be built:~%~{   ~a~%~}~;~]"
@@ -651,7 +655,8 @@ report what is prerequisites are available for download."
                   (N_ "~:[The following file will be downloaded:~%~{   ~a~%~}~;~]"
                       "~:[The following files will be downloaded:~%~{   ~a~%~}~;~]"
                       (length download))
-                  (null? download) download)))
+                  (null? download)
+                  (map substitutable-path download))))
     (pair? build)))
 
 (define show-what-to-build*
diff --git a/tests/derivations.scm b/tests/derivations.scm
index d4e1a32bb..f3aad1b90 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -831,10 +831,10 @@
                     (derivation-prerequisites-to-build store drv))
                    ((build* download*)
                     (derivation-prerequisites-to-build store drv
-                                                       #:substitutable?
+                                                       #:substitutable-info
                                                        (const #f))))
         (and (null? build)
-             (equal? download (list output))
+             (equal? (map substitutable-path download) (list output))
              (null? download*)
              (null? build*))))))
 
@@ -879,7 +879,7 @@
           ;; See <http://bugs.gnu.org/18747>.
           (and (null? build)
                (match download
-                 (((? string? item))
+                 (((= substitutable-path item))
                   (string=? item (derivation->output-path drv))))))))))
 
 (test-assert "derivation-prerequisites-to-build in 'check' mode"
-- 
2.13.0

  reply	other threads:[~2017-05-31 13:53 UTC|newest]

Thread overview: 13+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2017-05-31 13:49 bug#27162: [PATCH 0/6] Display how much will be downloaded Ludovic Courtès
2017-05-31 13:51 ` bug#27162: [PATCH 1/6] derivations: 'substitution-oracle' returns a <substitutable> Ludovic Courtès
2017-05-31 13:51   ` Ludovic Courtès [this message]
2017-05-31 13:51   ` bug#27162: [PATCH 3/6] ui: 'show-what-to-build' displays how much will be downloaded Ludovic Courtès
2017-05-31 13:51   ` bug#27162: [PATCH 4/6] syscalls: Provide 'free-disk-space' Ludovic Courtès
2017-05-31 13:51   ` bug#27162: [PATCH 5/6] ui: 'show-what-to-build' warns when we don't have enough disk space Ludovic Courtès
2017-05-31 13:51   ` bug#27162: [PATCH 6/6] substitute: Do not display the installed size Ludovic Courtès
2017-05-31 19:42 ` bug#27162: [PATCH 0/6] Display how much will be downloaded Maxim Cournoyer
2017-05-31 20:48   ` Ludovic Courtès
2017-05-31 21:39   ` Danny Milosavljevic
2017-05-31 22:02     ` Maxim Cournoyer
2017-06-02 16:49       ` Ludovic Courtès
2017-06-01 11:19     ` Ludovic Courtès

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20170531135159.8186-2-ludo@gnu.org \
    --to=ludo@gnu.org \
    --cc=27162@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.