04/05: graph: Add "module" node type.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit b06a70e05dc6252a3ecb28db5898de7ebc110973
Author: Ludovic Courtès <address@hidden>
Date:   Tue Mar 27 14:00:48 2018 +0200

    graph: Add "module" node type.
    
    * guix/scripts/graph.scm (module-from-package)
    (source-module-dependencies*): New procedures.
    (%module-node-type): New variable.
    (%node-types): Add it.
    * guix/modules.scm (source-module-dependencies): Export.
    * tests/graph.scm ("module graph"): New test.
    * doc/guix.texi (Invoking guix graph): Document it.
---
 doc/guix.texi          |  9 +++++++++
 guix/modules.scm       |  3 ++-
 guix/scripts/graph.scm | 38 ++++++++++++++++++++++++++++++++++++--
 tests/graph.scm        | 20 +++++++++++++++++++-
 4 files changed, 66 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 49b3dd1..2204285 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6997,6 +6997,15 @@ name instead of a package name, as in:
 @example
 guix graph -t derivation `guix system build -d my-config.scm`
 @end example
+
address@hidden module
+This is the graph of @dfn{package modules} (@pxref{Package Modules}).
+For example, the following command shows the graph for the package
+module that defines the @code{guile} package:
+
address@hidden
+guix graph -t module guile | dot -Tpdf > module-graph.pdf
address@hidden example
 @end table
 
 All the types above correspond to @emph{build-time dependencies}.  The
diff --git a/guix/modules.scm b/guix/modules.scm
index 6c602ed..bf656bb 100644
--- a/guix/modules.scm
+++ b/guix/modules.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +29,7 @@
             file-name->module-name
             module-name->file-name
 
+            source-module-dependencies
             source-module-closure
             live-module-closure
             guix-module-name?))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 78f09f1..346ca4e 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,9 +27,11 @@
   #:use-module (guix gexp)
   #:use-module (guix derivations)
   #:use-module (guix memoization)
+  #:use-module (guix modules)
   #:use-module ((guix build-system gnu) #:select (standard-packages))
   #:use-module (gnu packages)
   #:use-module (guix sets)
+  #:use-module ((guix utils) #:select (location-file))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -44,6 +46,7 @@
             %derivation-node-type
             %reference-node-type
             %referrer-node-type
+            %module-node-type
             %node-types
 
             guix-graph))
@@ -332,6 +335,36 @@ substitutes."
 
 
 ;;;
+;;; Scheme modules.
+;;;
+
+(define (module-from-package package)
+  (file-name->module-name (location-file (package-location package))))
+
+(define (source-module-dependencies* module)
+  "Like 'source-module-dependencies' but filter out modules that are not
+package modules, while attempting to retain user package modules."
+  (remove (match-lambda
+            (('guix _ ...) #t)
+            (('system _ ...) #t)
+            (('language _ ...) #t)
+            (('ice-9 _ ...) #t)
+            (('srfi _ ...) #t)
+            (_ #f))
+          (source-module-dependencies module)))
+
+(define %module-node-type
+  ;; Show the graph of package modules.
+  (node-type
+   (name "module")
+   (description "the graph of package modules")
+   (convert (lift1 (compose list module-from-package) %store-monad))
+   (identifier (lift1 identity %store-monad))
+   (label object->string)
+   (edges (lift1 source-module-dependencies* %store-monad))))
+
+
+;;;
 ;;; List of node types.
 ;;;
 
@@ -344,7 +377,8 @@ substitutes."
         %bag-emerged-node-type
         %derivation-node-type
         %reference-node-type
-        %referrer-node-type))
+        %referrer-node-type
+        %module-node-type))
 
 (define (lookup-node-type name)
   "Return the node type called NAME.  Raise an error if it is not found."
diff --git a/tests/graph.scm b/tests/graph.scm
index 00fd372..5faa192 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -271,6 +271,24 @@ edges."
                           (list txt out))
                   (equal? edges `((,txt ,out)))))))))))
 
+(test-assert "module graph"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (run-with-store %store
+      (export-graph '((gnu packages guile)) 'port
+                    #:node-type %module-node-type
+                    #:backend backend))
+
+    (let-values (((nodes edges) (nodes+edges)))
+      (and (member '(gnu packages guile)
+                   (match nodes
+                     (((ids labels) ...) ids)))
+           (->bool (and (member (list '(gnu packages guile)
+                                      '(gnu packages libunistring))
+                                edges)
+                        (member (list '(gnu packages guile)
+                                      '(gnu packages bdw-gc))
+                                edges)))))))
+
 (test-assert "node-edges"
   (run-with-store %store
     (let ((packages (fold-packages cons '())))