aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-03-25 12:41:18 +0100
committerLudovic Courtès <ludo@gnu.org>2020-03-29 15:32:17 +0200
commitc40bf5816cb3ffb59920a61f71bd34b53cac3637 (patch)
tree24da94bd79ec7cdd5899b678c4f072e8a002c59f
parent3b1886c9dd6941d753f6f2f17a30ec3ea69fc47e (diff)
downloadguix-c40bf5816cb3ffb59920a61f71bd34b53cac3637.tar
guix-c40bf5816cb3ffb59920a61f71bd34b53cac3637.tar.gz
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.
-rw-r--r--guix/store.scm56
-rw-r--r--tests/store.scm36
2 files changed, 92 insertions, 0 deletions
diff --git a/guix/store.scm b/guix/store.scm
index fdaae27914..b3641ef95d 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 b61a981b28..0458a34746 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)))