Merge branch 'master' into staging

1 files changed, 36 insertions, 2 deletions

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))
@@ -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."