guix system: Add 'dmd-graph' command.

* guix/scripts/system.scm (dmd-service-node-label,
  dmd-service-node-type, export-dmd-graph): New procedures.
  (show-help): Add 'dmd-graph'.
  (guix-system)[parse-sub-command]: Likewise.
  Honor it.
* doc/guix.texi (Invoking guix system): Document it.
  (dmd Services): Add an illustration and explanation.
* doc/images/dmd-graph.dot: New file.
* doc.am (DOT_FILES): Add it.

1 files changed, 32 insertions, 2 deletions

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 9160969b95..b5da57a9ce 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -36,6 +36,7 @@
   #:use-module (gnu system vm)
   #:use-module (gnu system grub)
   #:use-module (gnu services)
+  #:use-module (gnu services dmd)
   #:use-module (gnu packages grub)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
@@ -282,7 +283,7 @@ it atomically, and then run OS's activation script."
 
 
 ;;;
-;;; Graph.
+;;; Graphs.
 ;;;
 
 (define (service-node-label service)
@@ -311,6 +312,18 @@ list of services."
    (label service-node-label)
    (edges (lift1 (service-back-edges services) %store-monad))))
 
+(define (dmd-service-node-label service)
+  "Return a label for a node representing a <dmd-service>."
+  (string-join (map symbol->string (dmd-service-provision service))))
+
+(define (dmd-service-node-type services)
+  "Return a node type for SERVICES, a list of <dmd-service>."
+  (node-type
+   (name "dmd-service")
+   (description "the dependency graph of dmd services")
+   (identifier (lift1 dmd-service-node-label %store-monad))
+   (label dmd-service-node-label)
+   (edges (lift1 (dmd-service-back-edges services) %store-monad))))
 
 
 ;;;
@@ -410,6 +423,19 @@ building anything."
                   #:node-type (service-node-type services)
                   #:reverse-edges? #t)))
 
+(define (export-dmd-graph os port)
+  "Export the graph of dmd services of OS to PORT."
+  (let* ((services (operating-system-services os))
+         (pid1     (fold-services services
+                                  #:target-type dmd-root-service-type))
+         (dmds     (service-parameters pid1))     ;the list of <dmd-service>
+         (sinks    (filter (lambda (service)
+                             (null? (dmd-service-requirement service)))
+                           dmds)))
+    (export-graph sinks (current-output-port)
+                  #:node-type (dmd-service-node-type dmds)
+                  #:reverse-edges? #t)))
+
 
 ;;;
 ;;; Options.
@@ -435,6 +461,8 @@ Build the operating system declared in FILE according to ACTION.\n"))
    init             initialize a root file system to run GNU\n"))
   (display (_ "\
    extension-graph  emit the service extension graph in Dot format\n"))
+  (display (_ "\
+   dmd-graph        emit the graph of dmd services in Dot format\n"))
 
   (show-build-options-help)
   (display (_ "
@@ -543,7 +571,7 @@ Build the operating system declared in FILE according to ACTION.\n"))
         (let ((action (string->symbol arg)))
           (case action
             ((build vm vm-image disk-image reconfigure init
-              extension-graph)
+              extension-graph dmd-graph)
              (alist-cons 'action action result))
             (else (leave (_ "~a: unknown action~%") action))))))
 
@@ -611,6 +639,8 @@ Build the operating system declared in FILE according to ACTION.\n"))
           (case action
             ((extension-graph)
              (export-extension-graph os (current-output-port)))
+            ((dmd-graph)
+             (export-dmd-graph os (current-output-port)))
             (else
              (perform-action action os
                              #:dry-run? dry?