mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
store: Add 'topologically-sorted'.
* guix/store.scm (topologically-sorted): New procedure. * tests/store.scm ("topologically-sorted, one item", "topologically-sorted, several items", "topologically-sorted, more difficult"): New tests.
This commit is contained in:
parent
cd4027fa47
commit
50add47748
2 changed files with 67 additions and 0 deletions
|
@ -76,6 +76,7 @@ (define-module (guix store)
|
|||
references
|
||||
requisites
|
||||
referrers
|
||||
topologically-sorted
|
||||
valid-derivers
|
||||
query-derivation-outputs
|
||||
live-paths
|
||||
|
@ -589,6 +590,40 @@ (define (requisites store path)
|
|||
references, recursively)."
|
||||
(fold-path store cons '() path))
|
||||
|
||||
(define (topologically-sorted store paths)
|
||||
"Return a list containing PATHS and all their references sorted in
|
||||
topological order."
|
||||
(define (traverse)
|
||||
;; Do a simple depth-first traversal of all of PATHS.
|
||||
(let loop ((paths paths)
|
||||
(visited vlist-null)
|
||||
(result '()))
|
||||
(define (visit n)
|
||||
(vhash-cons n #t visited))
|
||||
|
||||
(define (visited? n)
|
||||
(vhash-assoc n visited))
|
||||
|
||||
(match paths
|
||||
((head tail ...)
|
||||
(if (visited? head)
|
||||
(loop tail visited result)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(loop (references store head)
|
||||
(visit head)
|
||||
result))
|
||||
(lambda (visited result)
|
||||
(loop tail
|
||||
visited
|
||||
(cons head result))))))
|
||||
(()
|
||||
(values visited result)))))
|
||||
|
||||
(call-with-values traverse
|
||||
(lambda (_ result)
|
||||
(reverse result))))
|
||||
|
||||
(define referrers
|
||||
(operation (query-referrers (store-path path))
|
||||
"Return the list of path that refer to PATH."
|
||||
|
|
|
@ -162,6 +162,38 @@ (define (same? x y)
|
|||
(equal? (valid-derivers %store o)
|
||||
(list (derivation-file-name d))))))
|
||||
|
||||
(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)))
|
||||
(c (add-text-to-store %store "c" "c" (list b)))
|
||||
(d (add-text-to-store %store "d" "d" (list c)))
|
||||
(s (topologically-sorted %store (list d))))
|
||||
(equal? s (list a b c d))))
|
||||
|
||||
(test-assert "topologically-sorted, several items"
|
||||
(let* ((a (add-text-to-store %store "a" "a"))
|
||||
(b (add-text-to-store %store "b" "b" (list a)))
|
||||
(c (add-text-to-store %store "c" "c" (list b)))
|
||||
(d (add-text-to-store %store "d" "d" (list c)))
|
||||
(s1 (topologically-sorted %store (list d a c b)))
|
||||
(s2 (topologically-sorted %store (list b d c a b d))))
|
||||
(equal? s1 s2 (list a b c d))))
|
||||
|
||||
(test-assert "topologically-sorted, more difficult"
|
||||
(let* ((a (add-text-to-store %store "a" "a"))
|
||||
(b (add-text-to-store %store "b" "b" (list a)))
|
||||
(c (add-text-to-store %store "c" "c" (list b)))
|
||||
(d (add-text-to-store %store "d" "d" (list c)))
|
||||
(w (add-text-to-store %store "w" "w"))
|
||||
(x (add-text-to-store %store "x" "x" (list w)))
|
||||
(y (add-text-to-store %store "y" "y" (list x d)))
|
||||
(s1 (topologically-sorted %store (list y)))
|
||||
(s2 (topologically-sorted %store (list c y)))
|
||||
(s3 (topologically-sorted %store (cons y (references %store y)))))
|
||||
(and (equal? s1 (list w x a b c d y))
|
||||
(equal? s2 (list a b c w x d y))
|
||||
(lset= string=? s1 s3))))
|
||||
|
||||
(test-assert "log-file, derivation"
|
||||
(let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
|
||||
(s (add-to-store %store "bash" #t "sha256"
|
||||
|
|
Loading…
Reference in a new issue