TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2020-03-25 12:41:18 +01:00
parent 3b1886c9dd
commit c40bf5816c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 92 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
guix/store.scm
View File

@ -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.
;;

36
tests/store.scm
View File

@ -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)))