From fca3a1020af9d4abe71ab8ab4e2a52011688f272 Mon Sep 17 00:00:00 2001 From: amz3 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 `' and keep +;; field accessor bracket free. record name *must* have brackets or everything +;; is broken +;; +;; Usage: +;; +;; (define-record-type 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* 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* label nodes edges properties) + + +(set-record-type-printer! + (lambda (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* 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* 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