diff options
| -rw-r--r-- | guix/store.scm | 56 | ||||
| -rw-r--r-- | tests/store.scm | 36 |
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))) |