[bug#36351] [PATCH 02/10] derivations: Rewrite and replace 'derivations-prerequisites-to-build'.

[Ludovic Courtès]

The new 'derivation-build-plan' procedure has a more appropriate
signature: it takes a list of <derivation-inputs> instead of taking one
<derivation>.  Its body is also much simpler.

* guix/derivations.scm (derivation-build-plan): New procedure.
(derivation-prerequisites-to-build): Express in terms of
'derivation-build-plan' and mark as deprecated.
* tests/derivations.scm: Change 'derivation-prerequisites-to-build'
tests to 'derivation-build-plan' and adjust accordingly.
---
 guix/derivations.scm  | 132 ++++++++++++++++++++----------------------
 tests/derivations.scm |  63 +++++++++++---------
 2 files changed, 97 insertions(+), 98 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 4df7b06181..f6e94694fd 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -21,6 +21,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -34,6 +35,7 @@
   #:use-module (guix base16)
   #:use-module (guix memoization)
   #:use-module (guix combinators)
+  #:use-module (guix deprecation)
   #:use-module (guix monads)
   #:use-module (gcrypt hash)
   #:use-module (guix base32)
@@ -50,7 +52,8 @@
             derivation-builder-environment-vars
             derivation-file-name
             derivation-prerequisites
-            derivation-prerequisites-to-build
+            derivation-build-plan
+            derivation-prerequisites-to-build     ;deprecated
 
             <derivation-output>
             derivation-output?
@@ -61,6 +64,7 @@
 
             <derivation-input>
             derivation-input?
+            derivation-input
             derivation-input-path
             derivation-input-derivation
             derivation-input-sub-derivations
@@ -341,82 +345,70 @@ substituter many times."
         (#f #f)
         ((key . value) value)))))
 
-(define* (derivation-prerequisites-to-build store drv
-                                            #:key
-                                            (mode (build-mode normal))
-                                            (outputs
-                                             (derivation-output-names drv))
-                                            (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-INFO must be a
-one-argument procedure similar to that returned by 'substitution-oracle'."
-  (define built?
-    (mlambda (item)
-      (valid-path? store item)))
+(define* (derivation-build-plan store inputs
+                                #:key
+                                (mode (build-mode normal))
+                                (substitutable-info
+                                 (substitution-oracle
+                                  store
+                                  (map derivation-input-derivation
+                                       inputs)
+                                  #:mode mode)))
+  "Given INPUTS, a list of derivation-inputs, return two values: the list of
+derivation to build, and the list of substitutable items that, together,
+allows INPUTS to be realized.
 
-  (define input-built?
-    (compose (cut any built? <>) derivation-input-output-paths))
+SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
+by 'substitution-oracle'."
+  (define (built? item)
+    (valid-path? store item))
 
-  (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-info <>) derivation-input-output-paths))
-
-  (define (derivation-built? drv* sub-drvs)
+  (define (input-built? input)
     ;; In 'check' mode, assume that DRV is not built.
     (and (not (and (eqv? mode (build-mode check))
-                   (eq? drv* drv)))
-         (every built? (derivation-output-paths drv* sub-drvs))))
+                   (member input inputs)))
+         (every built? (derivation-input-output-paths input))))
 
-  (define (derivation-substitutable-info drv sub-drvs)
-    (and (substitutable-derivation? drv)
-         (let ((info (filter-map substitutable-info
-                                 (derivation-output-paths drv sub-drvs))))
-           (and (= (length info) (length sub-drvs))
+  (define (input-substitutable-info input)
+    (and (substitutable-derivation? (derivation-input-derivation input))
+         (let* ((items (derivation-input-output-paths input))
+                (info  (filter-map substitutable-info items)))
+           (and (= (length info) (length items))
                 info))))
 
-  (let loop ((drv        drv)
-             (sub-drvs   outputs)
-             (build      '())                     ;list of <derivation-input>
-             (substitute '()))                    ;list of <substitutable>
-    (cond ((derivation-built? drv sub-drvs)
-           (values build substitute))
-          ((derivation-substitutable-info drv sub-drvs)
-           =>
-           (lambda (substitutables)
-             (values build
-                     (append substitutables substitute))))
-          (else
-           (let ((build  (if (substitutable-derivation? drv)
-                             build
-                             (cons (make-derivation-input
-                                    (derivation-file-name drv) sub-drvs)
-                                   build)))
-                 (inputs (remove (lambda (i)
-                                   (or (member i build) ; XXX: quadratic
-                                       (input-built? i)
-                                       (input-substitutable? i)))
-                                 (derivation-inputs drv))))
-             (fold2 loop
-                    (append inputs build)
-                    (append (append-map (lambda (input)
-                                          (if (and (not (input-built? input))
-                                                   (input-substitutable? 
input))
-                                              (map substitutable-info
-                                                   
(derivation-input-output-paths
-                                                    input))
-                                              '()))
-                                        (derivation-inputs drv))
-                            substitute)
-                    (map (lambda (i)
-                           (read-derivation-from-file
-                            (derivation-input-path i)))
-                         inputs)
-                    (map derivation-input-sub-derivations inputs)))))))
+  (let loop ((inputs     inputs)                  ;list of <derivation-input>
+             (build      '())                     ;list of <derivation>
+             (substitute '())                     ;list of <substitutable>
+             (visited    (set)))                  ;set of <derivation-input>
+    (match inputs
+      (()
+       (values build substitute))
+      ((input rest ...)
+       (cond ((set-contains? visited input)
+              (loop rest build substitute visited))
+             ((input-built? input)
+              (loop rest build substitute
+                    (set-insert input visited)))
+             ((input-substitutable-info input)
+              =>
+              (lambda (substitutables)
+                (loop rest build
+                      (append substitutables substitute)
+                      (set-insert input visited))))
+             (else
+              (let ((deps (derivation-inputs
+                           (derivation-input-derivation input))))
+                (loop (append deps rest)
+                      (cons (derivation-input-derivation input) build)
+                      substitute
+                      (set-insert input visited)))))))))
+
+(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
+  derivation-build-plan
+  (let-values (((build download)
+                (apply derivation-build-plan store
+                       (list (derivation-input drv)) rest)))
+    (values (map derivation-input build) download)))
 
 (define (read-derivation drv-port)
   "Read the derivation from DRV-PORT and return the corresponding <derivation>
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 93f4cdd8ee..35fb20bab0 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -809,13 +809,13 @@
              (equal? (pk 'x content) (pk 'y (call-with-input-file out 
get-string-all)))
              )))))
 
-(test-assert "build-expression->derivation and 
derivation-prerequisites-to-build"
+(test-assert "build-expression->derivation and derivation-build-plan"
   (let ((drv (build-expression->derivation %store "fail" #f)))
     ;; The only direct dependency is (%guile-for-build) and it's already
     ;; built.
-    (null? (derivation-prerequisites-to-build %store drv))))
+    (null? (derivation-build-plan %store (derivation-inputs drv)))))
 
-(test-assert "derivation-prerequisites-to-build when outputs already present"
+(test-assert "derivation-build-plan when outputs already present"
   (let* ((builder    `(begin ,(random-text) (mkdir %output) #t))
          (input-drv  (build-expression->derivation %store "input" builder))
          (input-path (derivation->output-path input-drv))
@@ -828,9 +828,12 @@
               (valid-path? %store output))
       (error "things already built" input-drv))
 
-    (and (equal? (map derivation-input-path
-                      (derivation-prerequisites-to-build %store drv))
-                 (list (derivation-file-name input-drv)))
+    (and (lset= equal?
+                (map derivation-file-name
+                     (derivation-build-plan %store
+                                            (list (derivation-input drv))))
+                (list (derivation-file-name input-drv)
+                      (derivation-file-name drv)))
 
          ;; Build DRV and delete its input.
          (build-derivations %store (list drv))
@@ -839,9 +842,10 @@
 
          ;; Now INPUT-PATH is missing, yet it shouldn't be listed as a
          ;; prerequisite to build because DRV itself is already built.
-         (null? (derivation-prerequisites-to-build %store drv)))))
+         (null? (derivation-build-plan %store
+                                       (list (derivation-input drv)))))))
 
-(test-assert "derivation-prerequisites-to-build and substitutes"
+(test-assert "derivation-build-plan and substitutes"
   (let* ((store  (open-connection))
          (drv    (build-expression->derivation store "prereq-subst"
                                                (random 1000)))
@@ -853,17 +857,19 @@
 
     (with-derivation-narinfo drv
       (let-values (((build download)
-                    (derivation-prerequisites-to-build store drv))
+                    (derivation-build-plan store
+                                           (list (derivation-input drv))))
                    ((build* download*)
-                    (derivation-prerequisites-to-build store drv
-                                                       #:substitutable-info
-                                                       (const #f))))
+                    (derivation-build-plan store
+                                           (list (derivation-input drv))
+                                           #:substitutable-info
+                                           (const #f))))
         (and (null? build)
              (equal? (map substitutable-path download) (list output))
              (null? download*)
-             (null? build*))))))
+             (equal? (list drv) build*))))))
 
-(test-assert "derivation-prerequisites-to-build and substitutes, 
non-substitutable build"
+(test-assert "derivation-build-plan and substitutes, non-substitutable build"
   (let* ((store  (open-connection))
          (drv    (build-expression->derivation store "prereq-no-subst"
                                                (random 1000)
@@ -876,16 +882,16 @@
 
     (with-derivation-narinfo drv
       (let-values (((build download)
-                    (derivation-prerequisites-to-build store drv)))
+                    (derivation-build-plan store
+                                           (list (derivation-input drv)))))
         ;; Despite being available as a substitute, DRV will be built locally
         ;; due to #:substitutable? #f.
         (and (null? download)
              (match build
-               (((? derivation-input? input))
-                (string=? (derivation-input-path input)
-                          (derivation-file-name drv)))))))))
+               (((= derivation-file-name build))
+                (string=? build (derivation-file-name drv)))))))))
 
-(test-assert "derivation-prerequisites-to-build and substitutes, local build"
+(test-assert "derivation-build-plan and substitutes, local build"
   (with-store store
     (let* ((drv    (build-expression->derivation store "prereq-subst-local"
                                                  (random 1000)
@@ -898,7 +904,8 @@
 
       (with-derivation-narinfo drv
         (let-values (((build download)
-                      (derivation-prerequisites-to-build store drv)))
+                      (derivation-build-plan store
+                                             (list (derivation-input drv)))))
           ;; #:local-build? is *not* synonymous with #:substitutable?, so we
           ;; must be able to substitute DRV's output.
           ;; See <http://bugs.gnu.org/18747>.
@@ -907,7 +914,7 @@
                  (((= substitutable-path item))
                   (string=? item (derivation->output-path drv))))))))))
 
-(test-assert "derivation-prerequisites-to-build in 'check' mode"
+(test-assert "derivation-build-plan in 'check' mode"
   (with-store store
     (let* ((dep (build-expression->derivation store "dep"
                                               `(begin ,(random-text)
@@ -919,13 +926,13 @@
       (delete-paths store (list (derivation->output-path dep)))
 
       ;; In 'check' mode, DEP must be rebuilt.
-      (and (null? (derivation-prerequisites-to-build store drv))
-           (match (derivation-prerequisites-to-build store drv
-                                                     #:mode (build-mode
-                                                             check))
-             ((input)
-              (string=? (derivation-input-path input)
-                        (derivation-file-name dep))))))))
+      (and (null? (derivation-build-plan store
+                                         (list (derivation-input drv))))
+           (lset= equal?
+                  (derivation-build-plan store
+                                         (list (derivation-input drv))
+                                         #:mode (build-mode check))
+                  (list drv dep))))))
 
 (test-assert "substitution-oracle and #:substitute? #f"
   (with-store store
-- 
2.22.0