elisp/graph: Add 'guix-package-graph' command

* scheme/emacs-guix/graph.scm (lookup-node-type, lookup-backend)
(package-graph, make-package-graph): New procedures.
* scheme/emacs-guix.scm: Autoload 'make-package-graph'.
* elisp/guix-graph.el (guix-package-graph): New command.
* elisp/guix-help.el (guix-help-specifications): Add it.
* doc/emacs-guix.texi (Miscellaneous Commands): Document it.

5 files changed, 105 insertions, 2 deletions

diff --git a/doc/emacs-guix.texi b/doc/emacs-guix.texi
index 325af98..e5697a3 100644
--- a/doc/emacs-guix.texi
+++ b/doc/emacs-guix.texi
@@ -496,6 +496,12 @@ And some more commands related to profiles and packages:
 
 @table @kbd
 
+@findex guix-package-graph
+@item M-x guix-package-graph
+Show a package graph.  You'll be prompted for a package name, graph
+backend and graph node type (everything can be completed with
+@key{TAB} key).
+
 @findex guix-apply-manifest
 @item M-x guix-apply-manifest
 Apply manifest file to the current profile or to a specified profile,
diff --git a/elisp/guix-graph.el b/elisp/guix-graph.el
index 0b4371d..c7c703a 100644
--- a/elisp/guix-graph.el
+++ b/elisp/guix-graph.el
@@ -26,6 +26,9 @@
 (require 'cl-lib)
 (require 'guix-external)
 (require 'guix-utils)
+(require 'guix-read)
+(require 'guix-repl)
+(require 'guix-guile)
 
 (defun guix-graph-backend->graph-type (backend)
   "Convert Guix graph BACKEND (string) to a graph type.
@@ -61,6 +64,27 @@ See `guix-graph-backend->graph-type' for the meaning of GRAPH-TYPE."
         (guix-view-graph graph-type graph-file)
       (error "Couldn't create a graph"))))
 
+;;;###autoload
+(defun guix-package-graph (package backend node-type)
+  "Show BACKEND/NODE-TYPE graph for a PACKAGE.
+PACKAGE can be either a package name or a package ID.
+Interactively, prompt for arguments."
+  (interactive
+   (list (guix-read-package-name)
+         (guix-read-graph-backend)
+         (guix-read-graph-node-type)))
+  (guix-make-view-graph
+   backend
+   (lambda (graph-type graph-file)
+     (guix-eval-read
+      (guix-make-guile-expression
+       'make-package-graph package
+       (cl-case graph-type
+         (dot  (guix-dot-arguments graph-file))
+         (html graph-file))
+       :node-type-name node-type
+       :backend-name backend)))))
+
 (provide 'guix-graph)
 
 ;;; guix-graph.el ends here
diff --git a/elisp/guix-help.el b/elisp/guix-help.el
index d7039e7..8643161 100644
--- a/elisp/guix-help.el
+++ b/elisp/guix-help.el
@@ -96,6 +96,9 @@
     guix-find-location
     guix-edit
 
+    "Other package related commands"
+    guix-package-graph
+
     "Magit-like interface"
     guix
 
diff --git a/scheme/emacs-guix.scm b/scheme/emacs-guix.scm
index 17cd64c..c445021 100644
--- a/scheme/emacs-guix.scm
+++ b/scheme/emacs-guix.scm
@@ -52,7 +52,8 @@
                                    package-source-build-derivation
                                    package-build-log-file)
   #:autoload (emacs-guix graph) (graph-backend-names
-                                 graph-node-type-names)
+                                 graph-node-type-names
+                                 make-package-graph)
   #:autoload (emacs-guix lint) (lint-checker-names)
   #:autoload (emacs-guix refresh) (refresh-updater-names))
 
diff --git a/scheme/emacs-guix/graph.scm b/scheme/emacs-guix/graph.scm
index e5cc904..2183d28 100644
--- a/scheme/emacs-guix/graph.scm
+++ b/scheme/emacs-guix/graph.scm
@@ -20,10 +20,19 @@
 ;;; Code:
 
 (define-module (emacs-guix graph)
+  #:use-module (ice-9 popen)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-26)
+  #:use-module (guix grafts)
   #:use-module (guix graph)
+  #:use-module (guix monads)
+  #:use-module (guix store)
   #:use-module (guix scripts graph)
+  #:autoload   (emacs-guix packages) (package-by-id-or-name)
   #:export (graph-backend-names
-            graph-node-type-names))
+            graph-node-type-names
+            make-package-graph))
 
 (define (graph-backend-names)
   "Return a list of names of available graph backends."
@@ -33,4 +42,64 @@
   "Return a list of names of available graph node types."
   (map node-type-name %node-types))
 
+;; Original 'lookup-node-type' and 'lookup-backend' procedures from
+;; (guix scripts graph) module are not suitable because they call
+;; 'leave' when lookup fails.
+
+(define (lookup-node-type name)
+  "Return the node type called NAME."
+  (find (lambda (type)
+          (string=? (node-type-name type) name))
+        %node-types))
+
+(define (lookup-backend name)
+  "Return the graph backend called NAME."
+  (find (lambda (backend)
+          (string=? (graph-backend-name backend) name))
+        %graph-backends))
+
+(define* (package-graph package port #:key node-type backend)
+  "Write PACKAGE graph representation to PORT."
+  ;; TODO This is blindly taken from 'guix-graph' procedure of (guix
+  ;; scripts graph) module.  Since we have a single PACKAGE, there
+  ;; should definitely be a way to simplify this (to avoid 'mapm' at
+  ;; least), but I have no idea how to deal with monads.
+  (with-store store
+    (with-fluids ((%file-port-name-canonicalization 'absolute))
+      (run-with-store store
+        (mlet %store-monad ((_     (set-grafting #f))
+                            (nodes (mapm %store-monad
+                                         (node-type-convert node-type)
+                                         (list package))))
+          (export-graph (concatenate nodes)
+                        port
+                        #:node-type node-type
+                        #:backend backend))))))
+
+(define* (make-package-graph package-id-or-name command-or-file
+                             #:key node-type-name backend-name)
+  "Make graph for PACKAGE-ID-OR-NAME.
+
+If COMMAND-OR-FILE is a list, pipe the graph representation to the shell
+command defined by this list of command arguments (usually a 'dot'
+call).
+
+If COMMAND-OR-FILE is a file name, write graph output to this file.
+
+Return #t if the graph was created successfully; return #f otherwise."
+  (and-let* ((package   (package-by-id-or-name package-id-or-name))
+             (node-type (lookup-node-type node-type-name))
+             (backend   (lookup-backend backend-name)))
+    (let ((graph-to-port (cut package-graph package <>
+                              #:node-type node-type
+                              #:backend backend)))
+      (if (list? command-or-file)
+          (let ((pipe (apply open-pipe* OPEN_WRITE command-or-file)))
+            (graph-to-port pipe)
+            (zero? (status:exit-val (close-pipe pipe))))
+          (with-output-to-file command-or-file
+            (lambda ()
+              (graph-to-port (current-output-port))
+              #t))))))
+
 ;;; graph.scm ends here