[jackhill/guix/guix.git] / guix / scripts / graph.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix scripts graph)
  #:use-module (guix ui)
  #:use-module (guix graph)
  #:use-module (guix scripts)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix gexp)
  #:use-module (guix derivations)
  #:use-module ((guix build-system gnu) #:select (standard-packages))
  #:use-module (gnu packages)
  #:use-module (guix sets)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:export (%package-node-type
            %bag-node-type
            %bag-with-origins-node-type
            %bag-emerged-node-type
            %derivation-node-type
            %reference-node-type
            %node-types

            guix-graph))

\f
;;;
;;; Package DAG.
;;;

(define (node-full-name thing)
  "Return a human-readable name to denote THING, a package, origin, or file
name."
  (cond ((package? thing)
         (package-full-name thing))
        ((origin? thing)
         (origin-actual-file-name thing))
        ((string? thing)                          ;file name
         (or (basename thing)
             (error "basename" thing)))
        (else
         (number->string (object-address thing) 16))))

(define (package-node-edges package)
  "Return the list of dependencies of PACKAGE."
  (match (package-direct-inputs package)
    (((labels packages . outputs) ...)
     ;; Filter out origins and other non-package dependencies.
     (filter package? packages))))

(define %package-node-type
  ;; Type for the traversal of package nodes.
  (node-type
   (name "package")
   (description "the DAG of packages, excluding implicit inputs")

   ;; We use package addresses as unique identifiers.  This generally works
   ;; well, but for generated package objects, we could end up with two
   ;; packages that are not 'eq?', yet map to the same derivation (XXX).
   (identifier (lift1 object-address %store-monad))
   (label node-full-name)
   (edges (lift1 package-node-edges %store-monad))))

\f
;;;
;;; Package DAG using bags.
;;;

(define (bag-node-identifier thing)
  "Return a unique identifier for THING, which may be a package, origin, or a
file name."
  ;; If THING is a file name (a string), we just return it; if it's a package
  ;; or origin, we return its address.  That gives us the object graph, but
  ;; that may differ from the derivation graph (for instance,
  ;; 'package-with-bootstrap-guile' generates fresh package objects, and
  ;; several packages that are not 'eq?' may actually map to the same
  ;; derivation.)  Thus, we lower THING and use its derivation file name as a
  ;; unique identifier.
  (with-monad %store-monad
    (if (string? thing)
        (return thing)
        (mlet %store-monad ((low (lower-object thing)))
          (return (if (derivation? low)
                      (derivation-file-name low)
                      low))))))

(define (bag-node-edges thing)
  "Return the list of dependencies of THING, a package or origin.
Dependencies may include packages, origin, and file names."
  (cond ((package? thing)
         (match (bag-direct-inputs (package->bag thing))
           (((labels things . outputs) ...)
            things)))
        ((origin? thing)
         (cons (origin-patch-guile thing)
               (if (or (pair? (origin-patches thing))
                       (origin-snippet thing))
                   (match (origin-patch-inputs thing)
                     (#f '())
                     (((labels dependencies _ ...) ...)
                      (delete-duplicates dependencies eq?)))
                   '())))
        (else
         '())))

(define %bag-node-type
  ;; Type for the traversal of package nodes via the "bag" representation,
  ;; which includes implicit inputs.
  (node-type
   (name "bag")
   (description "the DAG of packages, including implicit inputs")
   (identifier bag-node-identifier)
   (label node-full-name)
   (edges (lift1 (compose (cut filter package? <>) bag-node-edges)
                 %store-monad))))

(define %bag-with-origins-node-type
  (node-type
   (name "bag-with-origins")
   (description "the DAG of packages and origins, including implicit inputs")
   (identifier bag-node-identifier)
   (label node-full-name)
   (edges (lift1 (lambda (thing)
                   (filter (match-lambda
                             ((? package?) #t)
                             ((? origin?)  #t)
                             (_            #f))
                           (bag-node-edges thing)))
                 %store-monad))))

(define standard-package-set
  (memoize
   (lambda ()
     "Return the set of standard packages provided by GNU-BUILD-SYSTEM."
     (match (standard-packages)
       (((labels packages . output) ...)
        (list->setq packages))))))

(define (bag-node-edges-sans-bootstrap thing)
  "Like 'bag-node-edges', but pretend that the standard packages of
GNU-BUILD-SYSTEM have zero dependencies."
  (if (set-contains? (standard-package-set) thing)
      '()
      (bag-node-edges thing)))

(define %bag-emerged-node-type
  ;; Like %BAG-NODE-TYPE, but without the bootstrap subset of the DAG.
  (node-type
   (name "bag-emerged")
   (description "same as 'bag', but without the bootstrap nodes")
   (identifier bag-node-identifier)
   (label node-full-name)
   (edges (lift1 (compose (cut filter package? <>)
                          bag-node-edges-sans-bootstrap)
                 %store-monad))))

\f
;;;
;;; Derivation DAG.
;;;

(define (file->derivation file)
  "Read the derivation from FILE and return it."
  (call-with-input-file file read-derivation))

(define (derivation-dependencies obj)
  "Return the <derivation> objects and store items corresponding to the
dependencies of OBJ, a <derivation> or store item."
  (if (derivation? obj)
      (append (map (compose file->derivation derivation-input-path)
                   (derivation-inputs obj))
              (derivation-sources obj))
      '()))

(define (derivation-node-identifier node)
  "Return a unique identifier for NODE, which may be either a <derivation> or
a plain store file."
  (if (derivation? node)
      (derivation-file-name node)
      node))

(define (derivation-node-label node)
  "Return a label for NODE, a <derivation> object or plain store item."
  (store-path-package-name (match node
                             ((? derivation? drv)
                              (derivation-file-name drv))
                             ((? string? file)
                              file))))

(define %derivation-node-type
  ;; DAG of derivations.  Very accurate, very detailed, but usually too much
  ;; detailed.
  (node-type
   (name "derivation")
   (description "the DAG of derivations")
   (convert (lambda (package)
              (with-monad %store-monad
                (>>= (package->derivation package)
                     (lift1 list %store-monad)))))
   (identifier (lift1 derivation-node-identifier %store-monad))
   (label derivation-node-label)
   (edges (lift1 derivation-dependencies %store-monad))))

\f
;;;
;;; DAG of residual references (aka. run-time dependencies).
;;;

(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
substitutes."
  (lambda (store)
    (guard (c ((nix-protocol-error? c)
               (match (substitutable-path-info store (list item))
                 ((info)
                  (values (substitutable-references info) store))
                 (()
                  (leave (_ "references for '~a' are not known~%")
                         item)))))
      (values (references store item) store))))

(define %reference-node-type
  (node-type
   (name "references")
   (description "the DAG of run-time dependencies (store references)")
   (convert (lambda (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))))))
   (identifier (lift1 identity %store-monad))
   (label store-path-package-name)
   (edges references*)))

\f
;;;
;;; List of node types.
;;;

(define %node-types
  ;; List of all the node types.
  (list %package-node-type
        %bag-node-type
        %bag-with-origins-node-type
        %bag-emerged-node-type
        %derivation-node-type
        %reference-node-type))

(define (lookup-node-type name)
  "Return the node type called NAME.  Raise an error if it is not found."
  (or (find (lambda (type)
              (string=? (node-type-name type) name))
            %node-types)
      (leave (_ "~a: unknown node type~%") name)))

(define (list-node-types)
  "Print the available node types along with their synopsis."
  (display (_ "The available node types are:\n"))
  (newline)
  (for-each (lambda (type)
              (format #t "  - ~a: ~a~%"
                      (node-type-name type)
                      (node-type-description type)))
            %node-types))

\f
;;;
;;; Command-line options.
;;;

(define %options
  (list (option '(#\t "type") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'node-type (lookup-node-type arg)
                              result)))
        (option '("list-types") #f #f
                (lambda (opt name arg result)
                  (list-node-types)
                  (exit 0)))
        (option '(#\e "expression") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'expression arg result)))
        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix edit")))))

(define (show-help)
  ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be
  ;; translated.
  (display (_ "Usage: guix graph PACKAGE...
Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
  (display (_ "
  -t, --type=TYPE        represent nodes of the given TYPE"))
  (display (_ "
      --list-types       list the available graph types"))
  (display (_ "
  -e, --expression=EXPR  consider the package EXPR evaluates to"))
  (newline)
  (display (_ "
  -h, --help             display this help and exit"))
  (display (_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %default-options
  `((node-type . ,%package-node-type)))

\f
;;;
;;; Entry point.
;;;

(define (guix-graph . args)
  (with-error-handling
    (let* ((opts     (parse-command-line args %options
                                         (list %default-options)))
           (type     (assoc-ref opts 'node-type))
           (packages (filter-map (match-lambda
                                   (('argument . spec)
                                    (specification->package spec))
                                   (('expression . exp)
                                    (read/eval-package-expression exp))
                                   (_ #f))
                                 opts)))
      (with-store store
        (run-with-store store
          (mlet %store-monad ((nodes (mapm %store-monad
                                           (node-type-convert type)
                                           packages)))
            (export-graph (concatenate nodes)
                          (current-output-port)
                          #:node-type type))))))
  #t)

;;; graph.scm ends here
Commit	Line	Data
88856916	1	;;; GNU Guix --- Functional package management for GNU
f88282af	2	;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
88856916 LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (guix scripts graph)
	20	#:use-module (guix ui)
8fb58371	21	#:use-module (guix graph)
88981dd3	22	#:use-module (guix scripts)
88856916 LC	23	#:use-module (guix utils)
	24	#:use-module (guix packages)
	25	#:use-module (guix monads)
	26	#:use-module (guix store)
	27	#:use-module (guix gexp)
	28	#:use-module (guix derivations)
	29	#:use-module ((guix build-system gnu) #:select (standard-packages))
	30	#:use-module (gnu packages)
	31	#:use-module (guix sets)
88856916	32	#:use-module (srfi srfi-1)
38b92daa	33	#:use-module (srfi srfi-26)
88856916 LC	34	#:use-module (srfi srfi-34)
	35	#:use-module (srfi srfi-37)
	36	#:use-module (ice-9 match)
88856916 LC	37	#:export (%package-node-type
88856916 LC	38	%bag-node-type
38b92daa	39	%bag-with-origins-node-type
88856916 LC	40	%bag-emerged-node-type
	41	%derivation-node-type
	42	%reference-node-type
c1a8c5ab AK	43	%node-types
c1a8c5ab AK	44
88856916 LC	45	guix-graph))
	46
	47	\f
88856916 LC	48	;;;
	49	;;; Package DAG.
	50	;;;
	51
88856916 LC	52	(define (node-full-name thing)
	53	"Return a human-readable name to denote THING, a package, origin, or file
	54	name."
	55	(cond ((package? thing)
	56	(package-full-name thing))
	57	((origin? thing)
3b4d0103	58	(origin-actual-file-name thing))
88856916 LC	59	((string? thing) ;file name
	60	(or (basename thing)
	61	(error "basename" thing)))
	62	(else
	63	(number->string (object-address thing) 16))))
	64
	65	(define (package-node-edges package)
	66	"Return the list of dependencies of PACKAGE."
	67	(match (package-direct-inputs package)
	68	(((labels packages . outputs) ...)
	69	;; Filter out origins and other non-package dependencies.
	70	(filter package? packages))))
	71
	72	(define %package-node-type
	73	;; Type for the traversal of package nodes.
	74	(node-type
	75	(name "package")
	76	(description "the DAG of packages, excluding implicit inputs")
	77
	78	;; We use package addresses as unique identifiers. This generally works
	79	;; well, but for generated package objects, we could end up with two
	80	;; packages that are not 'eq?', yet map to the same derivation (XXX).
	81	(identifier (lift1 object-address %store-monad))
	82	(label node-full-name)
	83	(edges (lift1 package-node-edges %store-monad))))
	84
	85	\f
	86	;;;
	87	;;; Package DAG using bags.
	88	;;;
	89
	90	(define (bag-node-identifier thing)
	91	"Return a unique identifier for THING, which may be a package, origin, or a
	92	file name."
	93	;; If THING is a file name (a string), we just return it; if it's a package
	94	;; or origin, we return its address. That gives us the object graph, but
	95	;; that may differ from the derivation graph (for instance,
	96	;; 'package-with-bootstrap-guile' generates fresh package objects, and
	97	;; several packages that are not 'eq?' may actually map to the same
	98	;; derivation.) Thus, we lower THING and use its derivation file name as a
	99	;; unique identifier.
	100	(with-monad %store-monad
	101	(if (string? thing)
	102	(return thing)
	103	(mlet %store-monad ((low (lower-object thing)))
	104	(return (if (derivation? low)
	105	(derivation-file-name low)
	106	low))))))
	107
	108	(define (bag-node-edges thing)
38b92daa LC	109	"Return the list of dependencies of THING, a package or origin.
	110	Dependencies may include packages, origin, and file names."
	111	(cond ((package? thing)
	112	(match (bag-direct-inputs (package->bag thing))
	113	(((labels things . outputs) ...)
	114	things)))
	115	((origin? thing)
	116	(cons (origin-patch-guile thing)
	117	(if (or (pair? (origin-patches thing))
	118	(origin-snippet thing))
	119	(match (origin-patch-inputs thing)
	120	(#f '())
	121	(((labels dependencies _ ...) ...)
	122	(delete-duplicates dependencies eq?)))
	123	'())))
	124	(else
	125	'())))
88856916 LC	126
	127	(define %bag-node-type
	128	;; Type for the traversal of package nodes via the "bag" representation,
	129	;; which includes implicit inputs.
	130	(node-type
	131	(name "bag")
	132	(description "the DAG of packages, including implicit inputs")
	133	(identifier bag-node-identifier)
	134	(label node-full-name)
38b92daa LC	135	(edges (lift1 (compose (cut filter package? <>) bag-node-edges)
	136	%store-monad))))
	137
	138	(define %bag-with-origins-node-type
	139	(node-type
	140	(name "bag-with-origins")
	141	(description "the DAG of packages and origins, including implicit inputs")
	142	(identifier bag-node-identifier)
	143	(label node-full-name)
	144	(edges (lift1 (lambda (thing)
	145	(filter (match-lambda
	146	((? package?) #t)
	147	((? origin?) #t)
	148	(_ #f))
	149	(bag-node-edges thing)))
	150	%store-monad))))
88856916 LC	151
	152	(define standard-package-set
	153	(memoize
	154	(lambda ()
	155	"Return the set of standard packages provided by GNU-BUILD-SYSTEM."
	156	(match (standard-packages)
	157	(((labels packages . output) ...)
	158	(list->setq packages))))))
	159
	160	(define (bag-node-edges-sans-bootstrap thing)
	161	"Like 'bag-node-edges', but pretend that the standard packages of
	162	GNU-BUILD-SYSTEM have zero dependencies."
	163	(if (set-contains? (standard-package-set) thing)
	164	'()
	165	(bag-node-edges thing)))
	166
	167	(define %bag-emerged-node-type
	168	;; Like %BAG-NODE-TYPE, but without the bootstrap subset of the DAG.
	169	(node-type
	170	(name "bag-emerged")
	171	(description "same as 'bag', but without the bootstrap nodes")
	172	(identifier bag-node-identifier)
	173	(label node-full-name)
f88282af LC	174	(edges (lift1 (compose (cut filter package? <>)
	175	bag-node-edges-sans-bootstrap)
	176	%store-monad))))
88856916 LC	177
	178	\f
	179	;;;
	180	;;; Derivation DAG.
	181	;;;
	182
	183	(define (file->derivation file)
	184	"Read the derivation from FILE and return it."
	185	(call-with-input-file file read-derivation))
	186
	187	(define (derivation-dependencies obj)
	188	"Return the <derivation> objects and store items corresponding to the
	189	dependencies of OBJ, a <derivation> or store item."
	190	(if (derivation? obj)
	191	(append (map (compose file->derivation derivation-input-path)
	192	(derivation-inputs obj))
	193	(derivation-sources obj))
	194	'()))
	195
	196	(define (derivation-node-identifier node)
	197	"Return a unique identifier for NODE, which may be either a <derivation> or
	198	a plain store file."
	199	(if (derivation? node)
	200	(derivation-file-name node)
	201	node))
	202
	203	(define (derivation-node-label node)
	204	"Return a label for NODE, a <derivation> object or plain store item."
	205	(store-path-package-name (match node
	206	((? derivation? drv)
	207	(derivation-file-name drv))
	208	((? string? file)
	209	file))))
	210
	211	(define %derivation-node-type
	212	;; DAG of derivations. Very accurate, very detailed, but usually too much
	213	;; detailed.
	214	(node-type
	215	(name "derivation")
	216	(description "the DAG of derivations")
	217	(convert (lambda (package)
	218	(with-monad %store-monad
	219	(>>= (package->derivation package)
	220	(lift1 list %store-monad)))))
	221	(identifier (lift1 derivation-node-identifier %store-monad))
	222	(label derivation-node-label)
	223	(edges (lift1 derivation-dependencies %store-monad))))
	224
	225	\f
	226	;;;
	227	;;; DAG of residual references (aka. run-time dependencies).
	228	;;;
	229
	230	(define (references* item)
	231	"Return as a monadic value the references of ITEM, based either on the
	232	information available in the local store or using information about
	233	substitutes."
	234	(lambda (store)
	235	(guard (c ((nix-protocol-error? c)
	236	(match (substitutable-path-info store (list item))
	237	((info)
	238	(values (substitutable-references info) store))
	239	(()
	240	(leave (_ "references for '~a' are not known~%")
241	item)))))
242	(values (references store item) store))))
243
244	(define %reference-node-type
245	(node-type
246	(name "references")
247	(description "the DAG of run-time dependencies (store references)")
248	(convert (lambda (package)
249	;; Return the output file names of PACKAGE.
250	(mlet %store-monad ((drv (package->derivation package)))
251	(return (match (derivation->output-paths drv)
252	(((_ . file-names) ...)
253	file-names))))))
254	(identifier (lift1 identity %store-monad))
255	(label store-path-package-name)
256	(edges references*)))
257
258	\f
259	;;;
260	;;; List of node types.
261	;;;
262
263	(define %node-types
264	;; List of all the node types.
265	(list %package-node-type
266	%bag-node-type
38b92daa	267	%bag-with-origins-node-type
88856916 LC	268	%bag-emerged-node-type
	269	%derivation-node-type
	270	%reference-node-type))
	271
	272	(define (lookup-node-type name)
	273	"Return the node type called NAME. Raise an error if it is not found."
	274	(or (find (lambda (type)
	275	(string=? (node-type-name type) name))
	276	%node-types)
	277	(leave (_ "~a: unknown node type~%") name)))
	278
	279	(define (list-node-types)
	280	"Print the available node types along with their synopsis."
	281	(display (_ "The available node types are:\n"))
	282	(newline)
	283	(for-each (lambda (type)
	284	(format #t " - ~a: ~a~%"
	285	(node-type-name type)
	286	(node-type-description type)))
	287	%node-types))
	288
	289	\f
88856916 LC	290	;;;
	291	;;; Command-line options.
	292	;;;
	293
	294	(define %options
	295	(list (option '(#\t "type") #t #f
	296	(lambda (opt name arg result)
	297	(alist-cons 'node-type (lookup-node-type arg)
	298	result)))
	299	(option '("list-types") #f #f
	300	(lambda (opt name arg result)
	301	(list-node-types)
	302	(exit 0)))
4c8f997a LC	303	(option '(#\e "expression") #t #f
	304	(lambda (opt name arg result)
	305	(alist-cons 'expression arg result)))
88856916 LC	306	(option '(#\h "help") #f #f
	307	(lambda args
	308	(show-help)
	309	(exit 0)))
	310	(option '(#\V "version") #f #f
	311	(lambda args
	312	(show-version-and-exit "guix edit")))))
	313
	314	(define (show-help)
	315	;; TRANSLATORS: Here 'dot' is the name of a program; it must not be
	316	;; translated.
	317	(display (_ "Usage: guix graph PACKAGE...
	318	Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
	319	(display (_ "
	320	-t, --type=TYPE represent nodes of the given TYPE"))
	321	(display (_ "
	322	--list-types list the available graph types"))
4c8f997a LC	323	(display (_ "
4c8f997a LC	324	-e, --expression=EXPR consider the package EXPR evaluates to"))
88856916 LC	325	(newline)
	326	(display (_ "
	327	-h, --help display this help and exit"))
	328	(display (_ "
	329	-V, --version display version information and exit"))
	330	(newline)
	331	(show-bug-report-information))
	332
	333	(define %default-options
	334	`((node-type . ,%package-node-type)))
	335
	336	\f
	337	;;;
	338	;;; Entry point.
	339	;;;
	340
	341	(define (guix-graph . args)
	342	(with-error-handling
	343	(let* ((opts (parse-command-line args %options
	344	(list %default-options)))
88856916	345	(type (assoc-ref opts 'node-type))
4c8f997a LC	346	(packages (filter-map (match-lambda
	347	(('argument . spec)
	348	(specification->package spec))
	349	(('expression . exp)
	350	(read/eval-package-expression exp))
	351	(_ #f))
	352	opts)))
88856916 LC	353	(with-store store
	354	(run-with-store store
	355	(mlet %store-monad ((nodes (mapm %store-monad
	356	(node-type-convert type)
	357	packages)))
	358	(export-graph (concatenate nodes)
	359	(current-output-port)
	360	#:node-type type))))))
	361	#t)
	362
	363	;;; graph.scm ends here