2 files changed, 92 insertions(+), 1 deletions(-)

M guix/graph.scm
M tests/graph.scm

@@ 21,8 21,11 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix sets)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:export (node-type
             node-type?
             node-type-identifier


@@ 32,6 35,10 @@
             node-type-name
             node-type-description
 
+            node-edges
+            node-back-edges
+            node-transitive-edges
+
             %graphviz-backend
             graph-backend?
             graph-backend


@@ 63,6 70,54 @@
   (name        node-type-name)                    ;string
   (description node-type-description))            ;string
 
+(define (%node-edges type nodes cons-edge)
+  (with-monad %store-monad
+    (match type
+      (($ <node-type> identifier label node-edges)
+       (define (add-edge node edges)
+         (>>= (node-edges node)
+              (lambda (nodes)
+                (return (fold (cut cons-edge node <> <>)
+                              edges nodes)))))
+
+       (mlet %store-monad ((edges (foldm %store-monad
+                                         add-edge vlist-null nodes)))
+         (return (lambda (node)
+                   (reverse (vhash-foldq* cons '() node edges)))))))))
+
+(define (node-edges type nodes)
+  "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
+returns its edges.  NODES is taken to be the sinks of the global graph."
+  (%node-edges type nodes
+               (lambda (source target edges)
+                 (vhash-consq source target edges))))
+
+(define (node-back-edges type nodes)
+  "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
+returns its back edges.  NODES is taken to be the sinks of the global graph."
+  (%node-edges type nodes
+               (lambda (source target edges)
+                 (vhash-consq target source edges))))
+
+(define (node-transitive-edges nodes node-edges)
+  "Return the list of nodes directly or indirectly connected to NODES
+according to the NODE-EDGES procedure.  NODE-EDGES must be a one-argument
+procedure that, given a node, returns its list of direct dependents; it is
+typically returned by 'node-edges' or 'node-back-edges'."
+  (let loop ((nodes   (append-map node-edges nodes))
+             (result  '())
+             (visited (setq)))
+    (match nodes
+      (()
+       result)
+      ((head . tail)
+       (if (set-contains? visited head)
+           (loop tail result visited)
+           (let ((edges (node-edges head)))
+             (loop (append edges tail)
+                   (cons head result)
+                   (set-insert head visited))))))))
+
 
 ;;;
 ;;; Graphviz export.

@@ 25,8 25,12 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix build-system gnu)
+  #:use-module (guix build-system trivial)
   #:use-module (guix gexp)
+  #:use-module (guix utils)
   #:use-module (gnu packages)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages guile)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)


@@ 111,7 115,7 @@ edges."
                                    ".drv")))
                           implicit)))))))
 
-(test-assert "bag DAG"
+(test-assert "bag DAG"                            ;a big town in Iraq
   (let-values (((backend nodes+edges) (make-recording-backend)))
     (let ((p (dummy-package "p")))
       (run-with-store %store


@@ 188,6 192,38 @@ edges."
                           (list out txt))
                   (equal? edges `((,out ,txt)))))))))))
 
+(test-assert "node-edges"
+  (run-with-store %store
+    (let ((packages (fold-packages cons '())))
+      (mlet %store-monad ((edges (node-edges %package-node-type packages)))
+        (return (and (null? (edges grep))
+                     (lset= eq?
+                            (edges guile-2.0)
+                            (match (package-direct-inputs guile-2.0)
+                              (((labels packages _ ...) ...)
+                               packages)))))))))
+
+(test-assert "node-transitive-edges + node-back-edges"
+  (run-with-store %store
+    (let ((packages   (fold-packages cons '()))
+          (bootstrap? (lambda (package)
+                        (string-contains
+                         (location-file (package-location package))
+                         "bootstrap.scm")))
+          (trivial?   (lambda (package)
+                        (eq? (package-build-system package)
+                             trivial-build-system))))
+      (mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
+        (let* ((glibc      (canonical-package glibc))
+               (dependents (node-transitive-edges (list glibc) edges))
+               (diff       (lset-difference eq? packages dependents)))
+          ;; All the packages depend on libc, except bootstrap packages and
+          ;; some that use TRIVIAL-BUILD-SYSTEM.
+          (return (null? (remove (lambda (package)
+                                   (or (trivial? package)
+                                       (bootstrap? package)))
+                                 diff))))))))
+
 (test-end "graph")