03/13: store: Add #:cut? parameter to 'topologically-sorted'.

[guix-commits]

civodul pushed a commit to branch wip-system-bootstrap
in repository guix.

commit c68de02bd1e8bfdb2c20f49811179e695de60828
Author: Ludovic Courtès <address@hidden>
Date:   Thu Dec 12 12:55:42 2019 +0100

    store: Add #:cut? parameter to 'topologically-sorted'.
    
    * guix/store.scm (topologically-sorted): Add #:cut? and honor it.
    * tests/store.scm ("topologically-sorted, one item, cutting"): New
    test.
---
 guix/store.scm  | 30 +++++++++++++++++-------------
 tests/store.scm | 10 ++++++++++
 2 files changed, 27 insertions(+), 13 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index cf25d34..481131d 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1376,9 +1376,10 @@ SEED."
 its references, recursively)."
   (fold-path store cons '() paths))
 
-(define (topologically-sorted store paths)
+(define* (topologically-sorted store paths #:key (cut? (const #f)))
   "Return a list containing PATHS and all their references sorted in
-topological order."
+topological order.  Skip store items that match CUT? as well as their
+dependencies."
   (define (traverse)
     ;; Do a simple depth-first traversal of all of PATHS.
     (let loop ((paths   paths)
@@ -1392,17 +1393,20 @@ topological order."
 
       (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))))))
+         (cond ((visited? head)
+                (loop tail visited result))
+               ((cut? head)
+                (loop tail visited result))
+               (else
+                (call-with-values
+                    (lambda ()
+                      (loop (references store head)
+                            (visit head)
+                            result))
+                  (lambda (visited result)
+                    (loop tail
+                          visited
+                          (cons head result)))))))
         (()
          (values visited result)))))
 
diff --git a/tests/store.scm b/tests/store.scm
index 2b14a4a..49729b2 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -388,6 +388,16 @@
          (s (topologically-sorted %store (list d))))
     (equal? s (list a b c d))))
 
+(test-assert "topologically-sorted, one item, cutting"
+  (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)
+                                  #:cut?
+                                  (cut string-suffix? "-b" <>))))
+    (equal? s (list 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)))