02/02: graph: Add '%referrer-node-type'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 7f8fec0fa40951de33822f86c31c32e3f3c5513e
Author: Ludovic Courtès <address@hidden>
Date:   Sat Oct 15 22:47:42 2016 +0200

    graph: Add '%referrer-node-type'.
    
    * guix/scripts/graph.scm (ensure-store-items): New procedure.
    (%reference-node-type)[convert]: Use it.
    (non-derivation-referrers): New procedure.
    (%referrer-node-type): New variable.
    (%node-types): Add it.
    * tests/graph.scm ("referrer DAG"): New test.
    * doc/guix.texi (Invoking guix graph): Document it.
---
 doc/guix.texi          |   14 +++++++++++++
 guix/scripts/graph.scm |   53 ++++++++++++++++++++++++++++++++++--------------
 tests/graph.scm        |   22 ++++++++++++++++++++
 3 files changed, 74 insertions(+), 15 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 74733f4..47fc199 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5546,6 +5546,20 @@ example, the command below produces the reference graph 
of your profile
 @example
 guix graph -t references `readlink -f ~/.guix-profile`
 @end example
+
address@hidden referrers
+This is the graph of the @dfn{referrers} of a store item, as returned by
address@hidden gc --referrers} (@pxref{Invoking guix gc}).
+
+This relies exclusively on local information from your store.  For
+instance, let us suppose that the current Inkscape is available in 10
+profiles on your machine; @command{guix graph -t referrers inkscape}
+will show a graph rooted at Inkscape and with those 10 profiles linked
+to it.
+
+It can help determine what is preventing a store item from being garbage
+collected.
+
 @end table
 
 The available options are the following:
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 782fca5..2f70d64 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -42,6 +42,7 @@
             %bag-emerged-node-type
             %derivation-node-type
             %reference-node-type
+            %referrer-node-type
             %node-types
 
             guix-graph))
@@ -257,6 +258,24 @@ derivation graph")))))))
 ;;; DAG of residual references (aka. run-time dependencies).
 ;;;
 
+(define ensure-store-items
+  ;; Return a list of store items as a monadic value based on the given
+  ;; argument, which may be a store item or a package.
+  (match-lambda
+    ((? package? package)
+     ;; Return the output file names of PACKAGE.
+     (mlet %store-monad ((drv (package->derivation package)))
+       (return (match (derivation->output-paths drv)
+                 (((_ . file-names) ...)
+                  file-names)))))
+    ((? store-path? item)
+     (with-monad %store-monad
+       (return (list item))))
+    (x
+     (raise
+      (condition (&message (message "unsupported argument for \
+this type of graph")))))))
+
 (define (references* item)
   "Return as a monadic value the references of ITEM, based either on the
 information available in the local store or using information about
@@ -275,24 +294,27 @@ substitutes."
   (node-type
    (name "references")
    (description "the DAG of run-time dependencies (store references)")
-   (convert (match-lambda
-              ((? package? package)
-               ;; Return the output file names of PACKAGE.
-               (mlet %store-monad ((drv (package->derivation package)))
-                 (return (match (derivation->output-paths drv)
-                           (((_ . file-names) ...)
-                            file-names)))))
-              ((? store-path? item)
-               (with-monad %store-monad
-                 (return (list item))))
-              (x
-               (raise
-                (condition (&message (message "unsupported argument for \
-reference graph")))))))
+   (convert ensure-store-items)
    (identifier (lift1 identity %store-monad))
    (label store-path-package-name)
    (edges references*)))
 
+(define non-derivation-referrers
+  (let ((referrers (store-lift referrers)))
+    (lambda (item)
+      "Return the referrers of ITEM, except '.drv' files."
+      (mlet %store-monad ((items (referrers item)))
+        (return (remove derivation-path? items))))))
+
+(define %referrer-node-type
+  (node-type
+   (name "referrers")
+   (description "the DAG of referrers in the store")
+   (convert ensure-store-items)
+   (identifier (lift1 identity %store-monad))
+   (label store-path-package-name)
+   (edges non-derivation-referrers)))
+
 
 ;;;
 ;;; List of node types.
@@ -305,7 +327,8 @@ reference graph")))))))
         %bag-with-origins-node-type
         %bag-emerged-node-type
         %derivation-node-type
-        %reference-node-type))
+        %reference-node-type
+        %referrer-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 1ce06cc..f2e441c 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -232,6 +232,28 @@ edges."
                           (list out txt))
                   (equal? edges `((,out ,txt)))))))))))
 
+(test-assert "referrer DAG"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (run-with-store %store
+      (mlet* %store-monad ((txt   (text-file "referrer-node" (random-text)))
+                           (drv   (gexp->derivation "referrer"
+                                                    #~(symlink #$txt 
#$output)))
+                           (out -> (derivation->output-path drv)))
+        ;; We should see only TXT and OUT, with an edge from the former to the
+        ;; latter.
+        (mbegin %store-monad
+          (built-derivations (list drv))
+          (export-graph (list txt) 'port
+                        #:node-type %referrer-node-type
+                        #:backend backend)
+          (let-values (((nodes edges) (nodes+edges)))
+            (return
+             (and (equal? (match nodes
+                            (((ids labels) ...)
+                             ids))
+                          (list txt out))
+                  (equal? edges `((,txt ,out)))))))))))
+
 (test-assert "node-edges"
   (run-with-store %store
     (let ((packages (fold-packages cons '())))