02/03: graph: Add procedures to query a node's edges.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 923d846c4dfe0f51357d3329697f54c779148dde
Author: Ludovic Courtès <address@hidden>
Date:   Sat Nov 21 14:48:34 2015 +0100

    graph: Add procedures to query a node's edges.
    
    * guix/graph.scm (%node-edges, node-edges, node-back-edges)
    (node-transitive-edges): New procedures.
    * tests/graph.scm ("node-edges")
    ("node-transitive-edges + node-back-edges"): New tests.
---
 guix/graph.scm  |   55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/graph.scm |   38 +++++++++++++++++++++++++++++++++++++-
 2 files changed, 92 insertions(+), 1 deletions(-)

diff --git a/guix/graph.scm b/guix/graph.scm
index 05325ba..a39208e 100644
--- a/guix/graph.scm
+++ b/guix/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.
diff --git a/tests/graph.scm b/tests/graph.scm
index ed5849f..9c9e366 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -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")