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

[Amirouche Boubekki <amirouche@hypermove.net>]

[-- 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