[PATCH] guix: scripts: Add --dependencies=PACKAGE commmand

[PATCH] guix: scripts: Add --dependencies=PACKAGE commmand

[Amirouche Boubekki]

This is a first patch to request the interest and the feedback of the 
community to have something like that in guix and how it should be done.

  guix packacge --dependencies=PACKAGE

That will output the dot program required to generate a graph with 
graphviz.

The full bash line can be:

  guix package --dependencies=qsynth | dot -Tpng > qsynth-deps.png && 
icecat qsynth-deps.png


There is a *bug*: I am using `find-packages-by-name` which returns 
several packages,  but when the output is passed to graphviz only one of 
the package is drawn.

There is also an "interactive" web output [1].


HTH,

[1] http://www.hyperdev.fr/_drafts/guix-dependencies-in-sigmajs/sigmajs/

-- 
Amirouche ~ amz3 ~ http://www.hyperdev.fr

Re: [PATCH] guix: scripts: Add --dependencies=PACKAGE commmand

[Amirouche Boubekki]

[-- Attachment #1: Type: text/plain, Size: 857 bytes --]

Sorry my patch was missing a file.

On 2015-06-20 18:45, Amirouche Boubekki wrote:
> This is a first patch to request the interest and the feedback of the
> community to have something like that in guix and how it should be
> done.
> 
>  guix packacge --dependencies=PACKAGE
> 
> That will output the dot program required to generate a graph with 
> graphviz.
> 
> The full bash line can be:
> 
>  guix package --dependencies=qsynth | dot -Tpng > qsynth-deps.png &&
> icecat qsynth-deps.png
> 
> 
> There is a *bug*: I am using `find-packages-by-name` which returns
> several packages,  but when the output is passed to graphviz only one
> of the package is drawn.
> 
> There is also an "interactive" web output [1].
> 
> 
> HTH,
> 
> [1] 
> http://www.hyperdev.fr/_drafts/guix-dependencies-in-sigmajs/sigmajs/

-- 
Amirouche ~ amz3 ~ http://www.hyperdev.fr

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-guix-scripts-add-dependencies-PACKAGE-command.patch --]
[-- Type: text/x-diff; name=0001-guix-scripts-add-dependencies-PACKAGE-command.patch, Size: 14699 bytes --]

From fca3a1020af9d4abe71ab8ab4e2a52011688f272 Mon Sep 17 00:00:00 2001
From: amz3 <amirouche@hypermove.net>
Date: Sat, 20 Jun 2015 18:23:26 +0200
Subject: [PATCH] guix: scripts: add --dependencies=PACKAGE command

exemple usage:

  guix package --dependencies=qsynth | dot -Tpng > qsynth-deps.png

* guix/scripts/package.scm: add --dependencies command
* guix/scripts/dependencies.scm: graph datastructure and helpers
---
 guix/scripts/dependencies.scm | 312 ++++++++++++++++++++++++++++++++++++++++++
 guix/scripts/package.scm      |  23 ++++
 2 files changed, 335 insertions(+)
 create mode 100644 guix/scripts/dependencies.scm

diff --git a/guix/scripts/dependencies.scm b/guix/scripts/dependencies.scm
new file mode 100644
index 0000000..448d83d
--- /dev/null
+++ b/guix/scripts/dependencies.scm
@@ -0,0 +1,312 @@
+;; FIXME: copyright
+
+(define-module (guix scripts dependencies)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 rdelim)
+  #:use-module (guix packages)
+  #:use-module (gnu packages audio)
+  #:export (display-dependencies))
+
+
+;; Immutable graph datastructure
+
+;; FIXME: Taken from Guile, should be in (srfi srfi-99)
+;;        adapted to make it possible to declare record type like `<abc>' and keep
+;;        field accessor bracket free. record name *must* have brackets or everything
+;;        is broken
+;;
+;; Usage:
+;;
+;;   (define-record-type <abc> field-one field-two)
+;;   (define zzz (make-abc 1 2))
+;;   (abc-field-one zzz) ;; => 1
+;;
+;; FIXME: maybe this is less useful than the immutable record of (srfi srfi-9 gnu)
+;;        Right I will use `set-field` and `set-fields`
+(define-syntax define-record-type*
+  (lambda (x)
+    (define (%id-name name) (string->symbol (string-drop (string-drop-right (symbol->string name) 1) 1)))
+    (define (id-name ctx name)
+      (datum->syntax ctx (%id-name (syntax->datum name))))
+    (define (id-append ctx . syms)
+      (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
+    (syntax-case x ()
+      ((_ rname field ...)
+       (and (identifier? #'rname) (and-map identifier? #'(field ...)))
+       (with-syntax ((cons (id-append #'rname #'make- (id-name #'rname #'rname)))
+                     (pred (id-append #'rname (id-name #'rname #'rname) #'?))
+                     ((getter ...) (map (lambda (f)
+                                          (id-append f (id-name #'rname #'rname) #'- f))
+                                        #'(field ...))))
+         #'(define-record-type rname
+             (cons field ...)
+             pred
+             (field getter)
+             ...))))))
+
+(define-record-type* <node> identifier label outgoings incomings properties)
+
+
+;;;
+;;; Store
+;;;
+;;; Memory bound immutable association
+;;;
+
+
+;; XXX: It's assumed that keys are strings.
+;;
+;; This replace scheme assoc, because:
+;; 1) there is no immutable `assoc-set` in scheme
+;; 2) `acons` (and friends) can replace `assoc-set` but memory will grow without bound
+;; 3) `assoc-ref` (and friends) always return `#f` when no values is found
+;; 4) `vlist` and else can not be easily written to disk
+;; 5) It's fun
+
+
+(define (store-set store key value)
+  "Return a copy of STORE where KEY is set to VALUE"
+  (let loop ((assoc store)
+             (out '()))
+    (if (null? assoc)
+        (cons (cons key value) out)
+        (if (equal? (caar assoc) key)
+            (append (list (cons key value)) out (cdr assoc))
+            (loop (cdr assoc) (cons (car assoc) out))))))
+
+
+(define (store-ref store key)
+  "Return the value of KEY in STORE, if KEY is not found return #nil"
+  (let loop ((assoc store))
+    (if (null? assoc)
+        #nil
+        (if (equal? (caar assoc) key)
+            (cdar assoc)
+            (loop (cdr assoc))))))
+
+(define (store-del store key)
+  "Return a copy of STORE where the KEY association doesn't exists"
+  (let loop ((assoc store)
+             (out '()))
+    (if (null? assoc)
+        store
+        (if (equal? (caar assoc) key)
+            (append out (cdr assoc))
+            (loop (cdr assoc) (cons (car assoc) out))))))
+
+
+;;;
+;;; Graph
+;;;
+
+(define-record-type* <graph> label nodes edges properties)
+
+
+(set-record-type-printer! <graph>
+  (lambda (record port)
+    (display "<graph  label: \"" port)
+    (display (graph-label record) port)
+    (display "\" nodes: " port)
+    (display (length (graph-nodes record)) port)
+    (display " edges: " port)
+    (display (length (graph-edges record)) port)
+    (display " properties: " port)
+    (display (length (graph-properties record)) port)
+    (display ">" port)))
+
+(define (create-graph label)
+  (make-graph label '() '() '()))
+
+(define (graph-get-uid store)
+  (define CHARS "AZERTYUIOPQSDFGHJKLMWXCVBN1029384756")
+
+  (define (random-id)
+    (let loop ((count 4)
+               (id ""))
+      (if (eq? count 0)
+          id
+          (loop (1- count) (format #f "~a~a" id (string-ref CHARS (random 36)))))))
+
+  (let loop ()
+    (let ((id (random-id)))
+      (if (null? (store-ref store id))
+          id
+          (loop)))))
+
+;; properties get/set/ref
+
+(define (graph-property-set graph key value)
+  (let* ((properties (graph-properties graph)))
+    (set-field graph (graph-properties) (store-set properties key value))))
+
+(define (graph-property-del graph key)
+  (let* ((properties (graph-properties graph)))
+    (set-field graph (graph-properties) (store-del properties key))))
+
+(define (graph-property-ref graph key)
+  (let* ((properties (graph-properties graph)))
+    (store-ref properties key)))
+
+
+;;;
+;;; Node
+;;;
+
+(define-record-type* <node> identifier label outgoings incomings properties)
+
+(define (graph-create-node graph label)
+  (let* ((uid (graph-get-uid (graph-nodes graph)))
+         (node (make-node uid label '() '() '()))
+         (graph (set-field graph (graph-nodes) (store-set (graph-nodes graph) uid node))))
+    (values graph (node-identifier node))))
+
+(define (graph-node-ref graph uid)
+  (store-ref (graph-nodes graph) uid))
+
+(define (graph-node-label-ref graph label)
+  (graph-node-ref graph (graph-property-ref graph label)))
+
+(define (graph-node-property-set graph uid key value)
+  (let* ((node (graph-node-ref graph uid))
+        (properties (node-properties node))
+        (node (set-field  node (node-properties) (store-set properties key value)))
+        (nodes (graph-nodes graph)))
+    (set-field graph (graph-nodes) (store-set nodes uid node))))
+
+(define (graph-node-property-del graph uid key)
+  (let* ((node (graph-node-ref graph uid))
+        (properties (node-properties node))
+        (node (set-field  node (node-properties) (store-del properties key)))
+        (nodes (graph-nodes graph)))
+    (set-field graph (graph-nodes) (store-set nodes uid node))))
+
+(define (graph-node-property-ref graph uid key)
+  (let* ((node (graph-node-ref graph uid))
+         (properties (node-properties node)))
+    (store-ref properties key)))
+
+(define (%graph-node-edges graph uid edges-getter)
+  (let loop ((edges (edges-getter (graph-edge-ref graph uid)))
+             (out '()))
+    (if (null? edges)
+        out
+        (loop (cdr edges) (cons (graph-edge-ref graph (car edges)) out)))))
+
+(define (graph-node-outgoings graph uid)
+  (%graph-node-edges graph uid node-outgoings))
+
+(define (graph-node-incomings graph uid)
+  (%graph-node-edges graph uid node-incomings))
+
+;;;
+;;; Edge
+;;;
+
+(define-record-type* <edge> identifier start label end properties)
+
+(define (graph-create-edge graph start label end)
+  (let* ((uid (graph-get-uid (graph-edges graph)))
+         (edge (make-edge uid start label end '()))
+         (nodes (graph-nodes graph))
+
+         ;; add edge to `outgoings` of `start` node
+         (start-node (graph-node-ref graph start))
+         (outgoings (node-outgoings start-node))
+         (outgoings (cons uid outgoings))
+         (start-node (set-field start-node (node-outgoings) outgoings))
+         (nodes (store-set nodes start start-node))
+
+         ;; add edge to `incomings` of `end` node
+         (end-node (graph-node-ref graph end))
+         (incomings (node-incomings end-node))
+         (incomings (cons uid incomings))
+         (end-node (set-field end-node (node-incomings) incomings))
+         (nodes (store-set nodes end end-node))
+
+         ;; updates `nodes` field
+         (graph (set-field graph (graph-nodes) nodes)))
+    (values (set-field graph (graph-edges) (store-set (graph-edges graph) uid edge))
+            (edge-identifier edge))))
+
+(define (graph-edge-ref graph uid)
+  (store-ref (graph-edges graph) uid))
+
+(define (graph-edge-property-set graph uid key value)
+  (let* ((edge (graph-edge-ref graph uid))
+        (properties (edge-properties edge))
+        (edge (set-field  edge (edge-properties) (store-set properties key value)))
+        (edges (graph-edges graph)))
+    (set-field graph (graph-edges) (store-set edges uid edge))))
+
+(define (graph-edge-property-del graph uid key)
+  (let* ((edge (graph-edge-ref graph uid))
+        (properties (edge-properties edge))
+        (edge (set-field  edge (edge-properties) (store-del properties key)))
+        (edges (graph-edges graph)))
+    (set-field graph (graph-edges) (store-set edges uid edge))))
+
+(define (graph-edge-property-ref graph uid key)
+  (let* ((edge (graph-edge-ref graph uid))
+         (properties (edge-properties edge)))
+    (store-ref properties key)))
+
+(define (graph-edge-start graph uid)
+  (let* ((edge (graph-edge-ref graph uid)))
+    (graph-node-ref graph (edge-start edge))))
+
+(define (graph-edge-end graph uid)
+  (let* ((edge (graph-edge-ref graph uid)))
+    (graph-node-ref graph (edge-end edge))))
+
+
+;; Build dependency graph of a guix package
+
+(define (maybe-create-node graph label)
+  (if (graph-property-ref graph label)
+      (values graph (graph-property-ref graph label))
+      (let-values (((graph uid) (graph-create-node graph label)))
+        (values (graph-property-set graph label uid) uid))))
+
+(define (maybe-create-edge graph start label end)
+  (if (graph-property-ref graph label)
+      (values graph (graph-property-ref graph label))
+      (let-values (((graph uid) (graph-create-edge graph start label end)))
+        (values (graph-property-set graph label uid) uid))))
+
+(define (package-dependency-graph package graph)
+  (let loop ((packages (package-inputs package))
+             (graph graph))
+    (if (null? packages)
+        graph
+        (if (package? (cadar packages))
+            (let ((dependency (package-name (cadar packages))))
+              (let*-values (((graph package-uid) (maybe-create-node graph (package-name package)))
+                            ((graph dependency-uid) (maybe-create-node graph dependency)))
+                (let* ((label (string-append (package-name (cadar packages)) "--(depends)-->" dependency))
+                       (graph (maybe-create-edge graph package-uid label dependency-uid))
+                       (graph (package-dependency-graph (cadar packages) graph)))
+                (loop (cdr packages) graph))))
+            (loop (cdr packages) graph)))))
+
+(define (graph-dot graph port)
+  (format port
+          "digraph \"dependency graph of ~a\" {\n\tratio = \"auto\";\n\tmincross = 3.0;\n\tlabel = \"~a\"\n\n"
+          (graph-label graph)
+          (graph-label graph))
+  (let loop ((edges (graph-edges graph)))
+    (if (null? edges)
+        (format port "\n}\n")
+        (begin
+          (format port "\t\"~a\" -> \"~a\";\n"
+                  (node-label (graph-node-ref graph (edge-start (cdar edges))))
+                  (node-label (graph-node-ref graph (edge-end (cdar edges)))))
+          (loop (cdr edges))))))
+
+
+(define (display-dependencies package port)
+  (let* ((graph (create-graph (string-append "dependencies of " (package-name package))))
+         (graph (package-dependency-graph package graph)))
+    (graph-dot graph port)
+    graph))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 56a6e2d..6784c98 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -30,6 +30,7 @@
   #:use-module (guix utils)
   #:use-module (guix config)
   #:use-module (guix scripts build)
+  #:use-module (guix scripts dependencies)  
   #:use-module ((guix build utils)
                 #:select (directory-exists? mkdir-p search-path-as-list))
   #:use-module (ice-9 format)
@@ -427,6 +428,7 @@ Install, remove, or upgrade packages in a single transaction.\n"))
       --bootstrap        use the bootstrap Guile to build the profile"))
   (display (_ "
       --verbose          produce verbose output"))
+
   (newline)
   (display (_ "
   -s, --search=REGEXP    search in synopsis and description using REGEXP"))
@@ -438,6 +440,9 @@ Install, remove, or upgrade packages in a single transaction.\n"))
                          list available packages matching REGEXP"))
   (display (_ "
       --show=PACKAGE     show details about PACKAGE"))
+  (display (_ "
+      --dependencies=PACKAGE
+                         produce graphviz output of dependencies"))
   (newline)
   (show-build-options-help)
   (newline)
@@ -566,7 +571,17 @@ kind of search path~%")
                    (values (cons `(query show ,arg)
                                  result)
                            #f)))
+         (option '("dependencies") #t #t
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query dependencies ,arg)
+                                 result)
+                           #f)))
 
+                   ;; (let-values (((name version)
+                   ;;               (package-name->name+version arg)))
+                     
+                   ;;   ;; (display-dependencies (find-packages-by-name name))
+                   ;;   (values (cons #f result) #f))))
          %standard-build-options))
 
 (define (options->installable opts manifest)
@@ -983,6 +998,14 @@ more information.~%"))
                       (find-packages-by-name name version)))
            #t))
 
+        (('dependencies requested-name)
+         (let-values (((name version)
+                       (package-name->name+version requested-name)))
+           (leave-on-EPIPE
+            (for-each (cute display-dependencies <> (current-output-port))
+                      (find-packages-by-name name version)))
+           #t))
+        
         (('search-paths kind)
          (let* ((manifest (profile-manifest profile))
                 (entries  (manifest-entries manifest))
-- 
2.2.1

Re: [PATCH] guix: scripts: Add --dependencies=PACKAGE commmand

[Ludovic Courtès]

Amirouche Boubekki <amirouche@hypermove.net> skribis:

> From fca3a1020af9d4abe71ab8ab4e2a52011688f272 Mon Sep 17 00:00:00 2001
> From: amz3 <amirouche@hypermove.net>
> Date: Sat, 20 Jun 2015 18:23:26 +0200
> Subject: [PATCH] guix: scripts: add --dependencies=PACKAGE command
>
> exemple usage:
>
>   guix package --dependencies=qsynth | dot -Tpng > qsynth-deps.png
>
> * guix/scripts/package.scm: add --dependencies command
> * guix/scripts/dependencies.scm: graph datastructure and helpers

Thanks for working on this, this is a useful tool!

Please take some time to read the “Contributing” section of the manual,
and in particular the part about commit logs and coding style.  You’ll
quickly notice several things that need to be adjusted.  ;-)

Here’s a quick review:

> +++ b/guix/scripts/dependencies.scm
> @@ -0,0 +1,312 @@
> +;; FIXME: copyright

Indeed.

> +;; FIXME: Taken from Guile, should be in (srfi srfi-99)
> +;;        adapted to make it possible to declare record type like `<abc>' and keep
> +;;        field accessor bracket free. record name *must* have brackets or everything
> +;;        is broken
> +;;
> +;; Usage:
> +;;
> +;;   (define-record-type <abc> field-one field-two)
> +;;   (define zzz (make-abc 1 2))
> +;;   (abc-field-one zzz) ;; => 1
> +;;
> +;; FIXME: maybe this is less useful than the immutable record of (srfi srfi-9 gnu)
> +;;        Right I will use `set-field` and `set-fields`
> +(define-syntax define-record-type*

Please don’t add another ‘define-record-type’; the one from SRFI-9 will
be good enough here.

> +;;;
> +;;; Store
> +;;;
> +;;; Memory bound immutable association
> +;;;
> +
> +
> +;; XXX: It's assumed that keys are strings.
> +;;
> +;; This replace scheme assoc, because:
> +;; 1) there is no immutable `assoc-set` in scheme
> +;; 2) `acons` (and friends) can replace `assoc-set` but memory will grow without bound
> +;; 3) `assoc-ref` (and friends) always return `#f` when no values is found

That’s not a sufficient argument: one could just

  (define (assoc-set alist key value)
    (alist-cons key value
                (alist-delete key alist)))

Regardless, it may be that vhashes would work better here.

> +;;;
> +;;; Graph
> +;;;
> +
> +(define-record-type* <graph> label nodes edges properties)

[...]

> +(define (graph-get-uid store)
> +  (define CHARS "AZERTYUIOPQSDFGHJKLMWXCVBN1029384756")
> +
> +  (define (random-id)
> +    (let loop ((count 4)
> +               (id ""))
> +      (if (eq? count 0)
> +          id
> +          (loop (1- count) (format #f "~a~a" id (string-ref CHARS (random 36)))))))
> +
> +  (let loop ()
> +    (let ((id (random-id)))
> +      (if (null? (store-ref store id))
> +          id
> +          (loop)))))

What about:

  (define (graph-unique-identifier graph)
    "Return a unique identifier for GRAPH for use in the ‘dot’ output.”
    (number->string (object-address graph) 16))

?

> +        (if (package? (cadar packages))
> +            (let ((dependency (package-name (cadar packages))))
> +              (let*-values (((graph package-uid) (maybe-create-node graph (package-name package)))
> +                            ((graph dependency-uid) (maybe-create-node graph dependency)))
> +                (let* ((label (string-append (package-name (cadar packages)) "--(depends)-->" dependency))
> +                       (graph (maybe-create-edge graph package-uid label dependency-uid))
> +                       (graph (package-dependency-graph (cadar packages) graph)))
> +                (loop (cdr packages) graph))))
> +            (loop (cdr packages) graph)))))

car, cdr, cadar etc. are banned.  Please use ‘match’ or some specific
accessor (it may be that a record would be more appropriate here?)

> +(define (graph-dot graph port)

‘graph->dot’

> +                   ;; (let-values (((name version)
> +                   ;;               (package-name->name+version arg)))
> +                     
> +                   ;;   ;; (display-dependencies (find-packages-by-name name))
> +                   ;;   (values (cons #f result) #f))))

Leftover.

More importantly, I think this should be in a separate command, or maybe
as an option in ‘guix gc’ since ‘guix gc’ already has --references & co.

WDYT?

I think the graph part should be abstracted so that it can work on (1)
packages, (2) bags, and (3) derivations.  Ideally users would be able to
choose which of these they want to represent, from coarse-grain to
fine-grain.  (That part could be implemented as a later patch, but the
framework has to be prepared for that.)

Also, I’m not completely sure a separate graph representation (<node>,
<edge>, and <graph>) is needed.  Wouldn’t it be sufficient to work
directly on packages objects (or bags or derivations)?

Thanks,
Ludo’.