[bug#37730] [PATCH] Topologically sort recursively-imported packages

[Ludovic Courtès]

Hi Brian,

Thanks for the updated patch!

Brian Leung <address@hidden> skribis:

> From 915274d493116d063bfe2a953a9e855b8312711e Mon Sep 17 00:00:00 2001
> From: Brian Leung <address@hidden>
> Date: Fri, 11 Oct 2019 23:18:03 -0700
> Subject: [PATCH] guix: utils: Topologically sort recursively imported recipes.

[...]

> +  (define graph vlist-null)
> +  (define recipe-map vlist-null)
> +  (define stack (list package-name))
> +  (define accum '())
> +
> +  (define (topo-sort stack graph recipe-map accum)
> +    (if (null? stack)
> +        (reverse accum)
> +        (let ((head-package (car stack)))
> +          (match (vhash-assoc head-package graph)
> +            ((key . '())
> +             (let ((next-stack (cdr stack))
> +                   (next-accum (cons (cdr (vhash-assoc head-package 
> recipe-map))
> +                                     accum)))
> +               (topo-sort next-stack
> +                          graph
> +                          recipe-map
> +                          next-accum)))
> +            ((key . (dep . rest))
> +             (define (handle? dep)
> +               (and
> +                (not (equal? dep head-package))
> +                (not (vhash-assoc dep recipe-map))
> +                (not (exists? dep))))
> +             (let* ((next-stack (if (handle? dep)
> +                                    (cons dep stack)
> +                                    stack))
> +                    (next-graph (vhash-cons key rest graph)))
> +               (topo-sort next-stack
> +                          next-graph
> +                          recipe-map
> +                          accum)))
> +            (#f
> +             (receive (package-recipe . dependencies) (repo->guix-package 
> head-package repo)
> +               (let ((next-graph (vhash-cons head-package
> +                                             ;; dependencies has shape 
> '(("package-a" "package-b" ...))
> +                                             (car dependencies)
> +                                             graph))
> +                     (next-recipe-map (vhash-cons head-package
> +                                                  (or
> +                                                   package-recipe
> +                                                   '())
> +                                                  recipe-map)))
> +                 (topo-sort stack
> +                            next-graph
> +                            next-recipe-map
> +                            accum))))))))
> +
> +  (topo-sort stack graph recipe-map accum))

I found this to be relatively complex (and part of this complexity was
already there before the patch) and quite different from the other
graph-walking procedures we have in different places, which got me
thinking why that is.

After a bit of researching and trying, I found that the attached patch
expresses the same thing, including topological sorting, in a hopefully
clearer way, or at least more consistent with other graph-walking
procedures in the code.  WDYT?

If that’s fine with you, I’d be willing to apply this patch, and then
apply other bits of your patch (the tests and stream removal) on top of
it.  How does that sound?

Returning a topologically-sorted set of packages means that nothing is
output until we’ve walked the whole dependency graph, so we indeed have
to get rid of streams.  I guess it’s a tradeoff.  Ricardo, how do you
feel about this change?

Thanks!

Ludo’.

diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 4694b6e7ef..bdce902d87 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -34,12 +34,14 @@
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix download)
+  #:use-module (guix sets)
   #:use-module (gnu packages)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-41)
@@ -377,40 +379,51 @@ separated by PRED."
                                       (chr (char-downcase chr)))
                                     name)))
 
+(define (topological-sort nodes
+                          node-dependencies
+                          node-name)
+  "Perform a breadth-first traversal of the graph rooted at NODES, a list of
+nodes, and return the list of nodes sorted in topological order.  Call
+NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
+obtain a node's uniquely identifying \"key\"."
+  (let loop ((nodes nodes)
+             (result '())
+             (visited (set)))
+    (match nodes
+      (()
+       (reverse result))
+      ((head . tail)
+       (if (set-contains? visited (node-name head))
+           (loop tail result visited)
+           (let ((dependencies (node-dependencies head)))
+             (loop (append dependencies tail)
+                   (cons head result)
+                   (set-insert (node-name head) visited))))))))
+
 (define* (recursive-import package-name repo
                            #:key repo->guix-package guix-name
                            #:allow-other-keys)
   "Generate a stream of package expressions for PACKAGE-NAME and all its
 dependencies."
-  (define (exists? dependency)
-    (not (null? (find-packages-by-name (guix-name dependency)))))
-  (define initial-state (list #f (list package-name) (list)))
-  (define (step state)
-    (match state
-      ((prev (next . rest) done)
-       (define (handle? dep)
-         (and
-           (not (equal? dep next))
-           (not (member dep done))
-           (not (exists? dep))))
-       (receive (package . dependencies) (repo->guix-package next repo)
-         (list
-           (if package package '()) ;; default #f on failure would interrupt
-           (if package
-             (lset-union equal? rest (filter handle? (car dependencies)))
-             rest)
-           (cons next done))))
-      ((prev '() done)
-       (list #f '() done))))
+  (define-record-type <node>
+    (make-node name package dependencies)
+    node?
+    (name         node-name)
+    (package      node-package)
+    (dependencies node-dependencies))
 
-  ;; Generate a lazy stream of package expressions for all unknown
-  ;; dependencies in the graph.
-  (stream-unfold
-    ;; map: produce a stream element
-    (match-lambda ((latest queue done) latest))
-    ;; predicate
-    (match-lambda ((latest queue done) latest))
-    ;; generator: update the queue
-    step
-    ;; initial state
-    (step initial-state)))
+  (define (exists? name)
+    (not (null? (find-packages-by-name (guix-name name)))))
+
+  (define (lookup-node name)
+    (receive (package dependencies) (repo->guix-package name repo)
+      (make-node name package dependencies)))
+
+  (list->stream                                   ;TODO: remove streams
+   (map node-package
+        (topological-sort (list (lookup-node package-name))
+                          (lambda (node)
+                            (map lookup-node
+                                 (remove exists?
+                                         (node-dependencies node))))
+                          node-name))))