From b06a70e05dc6252a3ecb28db5898de7ebc110973 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 27 Mar 2018 14:00:48 +0200
Subject: 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 49b3dd10d7..2204285516 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
+
+@item 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:
+
+@example
+guix graph -t module guile | dot -Tpdf > module-graph.pdf
+@end 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 6c602eda48..bf656bb241 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 <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; 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 78f09f181b..346ca4ea88 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 <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; 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))
@@ -330,6 +333,36 @@ substitutes."
    (label store-path-package-name)
    (edges non-derivation-referrers)))
 
+
+;;;
+;;; 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 00fd37243c..5faa19298a 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 <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; 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 '())))
-- 
cgit v1.2.3