* Re: [PATCH] guix: scripts: Add --dependencies=PACKAGE commmand
2015-06-20 16:45 [PATCH] guix: scripts: Add --dependencies=PACKAGE commmand Amirouche Boubekki
@ 2015-06-20 17:07 ` Amirouche Boubekki
2015-06-24 20:18 ` Ludovic Courtès
0 siblings, 1 reply; 3+ messages in thread
From: Amirouche Boubekki @ 2015-06-20 17:07 UTC (permalink / raw)
To: Guix Devel; +Cc: guix-devel-bounces+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
^ permalink raw reply related [flat|nested] 3+ messages in thread