aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-01-23 22:13:27 +0100
committerLudovic Courtès <ludo@gnu.org>2014-01-24 00:01:50 +0100
commit50add47748eb40371d8b88208a13e7230d15c220 (patch)
tree50d4813ddfdb39db532335bfcd8eba0b294bdff3
parentcd4027fa478e20b59e798dd163a54e7ff9c42c98 (diff)
downloadguix-50add47748eb40371d8b88208a13e7230d15c220.tar
guix-50add47748eb40371d8b88208a13e7230d15c220.tar.gz
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.
-rw-r--r--guix/store.scm35
-rw-r--r--tests/store.scm32
2 files changed, 67 insertions, 0 deletions
diff --git a/guix/store.scm b/guix/store.scm
index ede64341c5..eca0de7d97 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -76,6 +76,7 @@
references
requisites
referrers
+ topologically-sorted
valid-derivers
query-derivation-outputs
live-paths
@@ -589,6 +590,40 @@ SEED."
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."
diff --git a/tests/store.scm b/tests/store.scm
index 5ae036c060..a61d449fb4 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -162,6 +162,38 @@
(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"