01/11: store: Add 'map/accumulate-builds'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit c40bf5816cb3ffb59920a61f71bd34b53cac3637
Author: Ludovic Courtès <address@hidden>
AuthorDate: Wed Mar 25 12:41:18 2020 +0100

    store: Add 'map/accumulate-builds'.
    
    * guix/store.scm (<unresolved>): New record type.
    (build-accumulator, map/accumulate-builds, mapm/accumulate-builds): New
    procedures.
    * tests/store.scm ("map/accumulate-builds", "mapm/accumulate-builds"):
    New tests.
---
 guix/store.scm  | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/store.scm | 36 ++++++++++++++++++++++++++++++++++++
 2 files changed, 92 insertions(+)

diff --git a/guix/store.scm b/guix/store.scm
index fdaae27..b3641ef 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -105,6 +105,8 @@
             add-file-tree-to-store
             binary-file
             with-build-handler
+            map/accumulate-builds
+            mapm/accumulate-builds
             build-things
             build
             query-failed-paths
@@ -1263,6 +1265,48 @@ deals with \"dynamic dependencies\" such as 
grafts---derivations that depend
 on the build output of a previous derivation."
   (call-with-build-handler handler (lambda () exp ...)))
 
+;; Unresolved dynamic dependency.
+(define-record-type <unresolved>
+  (unresolved things continuation)
+  unresolved?
+  (things       unresolved-things)
+  (continuation unresolved-continuation))
+
+(define (build-accumulator continue store things mode)
+  "This build handler accumulates THINGS and returns an <unresolved> object."
+  (if (= mode (build-mode normal))
+      (unresolved things continue)
+      (continue #t)))
+
+(define (map/accumulate-builds store proc lst)
+  "Apply PROC over each element of LST, accumulating 'build-things' calls and
+coalescing them into a single call."
+  (define result
+    (map (lambda (obj)
+           (with-build-handler build-accumulator
+             (proc obj)))
+         lst))
+
+  (match (append-map (lambda (obj)
+                       (if (unresolved? obj)
+                           (unresolved-things obj)
+                           '()))
+                     result)
+    (()
+     result)
+    (to-build
+     ;; We've accumulated things TO-BUILD.  Actually build them and resume the
+     ;; corresponding continuations.
+     (build-things store (delete-duplicates to-build))
+     (map/accumulate-builds store
+                            (lambda (obj)
+                              (if (unresolved? obj)
+                                  ;; Pass #f because 'build-things' is now
+                                  ;; unnecessary.
+                                  ((unresolved-continuation obj) #f)
+                                  obj))
+                            result))))
+
 (define build-things
   (let ((build (operation (build-things (string-list things)
                                         (integer mode))
@@ -1789,6 +1833,18 @@ taking the store as its first argument."
                           (lambda (store . args)
                             (run-with-store store (apply proc args)))))
 
+(define (mapm/accumulate-builds mproc lst)
+  "Like 'mapm' in %STORE-MONAD, but accumulate 'build-things' calls and
+coalesce them into a single call."
+  (lambda (store)
+    (values (map/accumulate-builds store
+                                   (lambda (obj)
+                                     (run-with-store store
+                                       (mproc obj)))
+                                   lst)
+            store)))
+
+
 ;;
 ;; Store monad operators.
 ;;
diff --git a/tests/store.scm b/tests/store.scm
index b61a981..0458a34 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -412,6 +412,42 @@
       (build-derivations %store (list d2))
       'fail)))
 
+(test-assert "map/accumulate-builds"
+  (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
+         (s  (add-to-store %store "bash" #t "sha256"
+                           (search-bootstrap-binary "bash"
+                                                    (%current-system))))
+         (d1 (derivation %store "the-thing"
+                         s `("-e" ,b)
+                         #:env-vars `(("foo" . ,(random-text)))
+                         #:sources (list b s)))
+         (d2 (derivation %store "the-thing"
+                         s `("-e" ,b)
+                         #:env-vars `(("foo" . ,(random-text))
+                                      ("bar" . "baz"))
+                         #:sources (list b s))))
+    (with-build-handler (lambda (continue store things mode)
+                          (equal? (map derivation-file-name (list d1 d2))
+                                  things))
+      (map/accumulate-builds %store
+                             (lambda (drv)
+                               (build-derivations %store (list drv))
+                               (add-to-store %store "content-addressed"
+                                             #t "sha256"
+                                             (derivation->output-path drv)))
+                             (list d1 d2)))))
+
+(test-assert "mapm/accumulate-builds"
+  (let* ((d1 (run-with-store %store
+               (gexp->derivation "foo" #~(mkdir #$output))))
+         (d2 (run-with-store %store
+               (gexp->derivation "bar" #~(mkdir #$output)))))
+    (with-build-handler (lambda (continue store things mode)
+                          (equal? (map derivation-file-name (pk 'zz (list d1 
d2)))
+                                  (pk 'XX things)))
+      (run-with-store %store
+        (mapm/accumulate-builds built-derivations `((,d1) (,d2)))))))
+
 (test-assert "topologically-sorted, one item"
   (let* ((a (add-text-to-store %store "a" "a"))
          (b (add-text-to-store %store "b" "b" (list a)))