From fcbe4f71ca7ab7f8526bd1643044d204390ec6c2 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 6 Dec 2019 23:04:57 +0100
Subject: [PATCH] derivations: Add 'derivation-input-fold'.

* guix/derivations.scm (derivation-input-fold): New procedure.
(substitution-oracle)[closure]: Rewrite in terms of
'derivation-input-fold'.
* tests/derivations.scm ("derivation-input-fold"): New test.
---
 guix/derivations.scm  | 52 +++++++++++++++++++++++++++----------------
 tests/derivations.scm | 18 +++++++++++++++
 2 files changed, 51 insertions(+), 19 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 6cdf55b1fe..480a65c78b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -86,6 +86,7 @@
             fixed-output-derivation?
             offloadable-derivation?
             substitutable-derivation?
+            derivation-input-fold
             substitution-oracle
             derivation-hash
             derivation-properties
@@ -303,6 +304,29 @@ result is the set of prerequisites of DRV not already in valid."
             (derivation-output-path (assoc-ref outputs sub-drv)))
           sub-drvs))))
 
+(define* (derivation-input-fold proc seed inputs
+                                #:key (cut? (const #f)))
+  "Perform a breadth-first traversal of INPUTS, calling PROC on each input
+with the current result, starting from SEED.  Skip recursion on inputs that
+match CUT?."
+  (let loop ((inputs inputs)
+             (result seed)
+             (visited (set)))
+    (match inputs
+      (()
+       result)
+      ((input rest ...)
+       (let ((key (derivation-input-key input)))
+         (cond ((set-contains? visited key)
+                (loop rest result visited))
+               ((cut? input)
+                (loop rest result (set-insert key visited)))
+               (else
+                (let ((drv (derivation-input-derivation input)))
+                  (loop (append (derivation-inputs drv) rest)
+                        (proc input result)
+                        (set-insert key visited))))))))))
+
 (define* (substitution-oracle store inputs-or-drv
                               #:key (mode (build-mode normal)))
   "Return a one-argument procedure that, when passed a store file name,
@@ -322,25 +346,15 @@ substituter many times."
     (cut valid-derivation-input? store <>))
 
   (define (closure inputs)
-    (let loop ((inputs inputs)
-               (closure '())
-               (visited (set)))
-      (match inputs
-        (()
-         (reverse closure))
-        ((input rest ...)
-         (let ((key (derivation-input-key input)))
-           (cond ((set-contains? visited key)
-                  (loop rest closure visited))
-                 ((valid-input? input)
-                  (loop rest closure (set-insert key visited)))
-                 (else
-                  (let ((drv (derivation-input-derivation input)))
-                    (loop (append (derivation-inputs drv) rest)
-                          (if (substitutable-derivation? drv)
-                              (cons input closure)
-                              closure)
-                          (set-insert key visited))))))))))
+    (reverse
+     (derivation-input-fold (lambda (input closure)
+                              (let ((drv (derivation-input-derivation input)))
+                                (if (substitutable-derivation? drv)
+                                    (cons input closure)
+                                    closure)))
+                            '()
+                            inputs
+                            #:cut? valid-input?)))
 
   (let* ((inputs (closure (map (match-lambda
                                  ((? derivation-input? input)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 6a7fad85b5..ef6cec6c76 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -978,6 +978,24 @@
                                          #:mode (build-mode check))
                   (list drv dep))))))
 
+(test-assert "derivation-input-fold"
+  (let* ((builder (add-text-to-store %store "my-builder.sh"
+                                     "echo hello, world > \"$out\"\n"
+                                     '()))
+         (drv1    (derivation %store "foo"
+                              %bash `(,builder)
+                              #:sources `(,%bash ,builder)))
+         (drv2    (derivation %store "bar"
+                              %bash `(,builder)
+                              #:inputs `((,drv1))
+                              #:sources `(,%bash ,builder))))
+    (equal? (derivation-input-fold (lambda (input result)
+                                     (cons (derivation-input-derivation input)
+                                           result))
+                                   '()
+                                   (list (derivation-input drv2)))
+            (list drv1 drv2))))
+
 (test-assert "substitution-oracle and #:substitute? #f"
   (with-store store
     (let* ((dep   (build-expression->derivation store "dep"
-- 
2.20.1