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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 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 graph)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix sets)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (node-type
            node-type?
            node-type-identifier
            node-type-label
            node-type-edges
            node-type-convert
            node-type-name
            node-type-description

            node-edges
            node-back-edges
            node-transitive-edges

            %graphviz-backend
            graph-backend?
            graph-backend

            export-graph))

;;; Commentary:
;;;
;;; This module provides an abstract way to represent graphs and to manipulate
;;; them.  It comes with several such representations for packages,
;;; derivations, and store items.  It also provides a generic interface for
;;; exporting graphs in an external format, including a Graphviz
;;; implementation thereof.
;;;
;;; Code:

\f
;;;
;;; Node types.
;;;

(define-record-type* <node-type> node-type make-node-type
  node-type?
  (identifier  node-type-identifier)              ;node -> M identifier
  (label       node-type-label)                   ;node -> string
  (edges       node-type-edges)                   ;node -> M list of nodes
  (convert     node-type-convert                  ;package -> M list of nodes
               (default (lift1 list %store-monad)))
  (name        node-type-name)                    ;string
  (description node-type-description))            ;string

(define (%node-edges type nodes cons-edge)
  (with-monad %store-monad
    (match type
      (($ <node-type> identifier label node-edges)
       (define (add-edge node edges)
         (>>= (node-edges node)
              (lambda (nodes)
                (return (fold (cut cons-edge node <> <>)
                              edges nodes)))))

       (mlet %store-monad ((edges (foldm %store-monad
                                         add-edge vlist-null nodes)))
         (return (lambda (node)
                   (reverse (vhash-foldq* cons '() node edges)))))))))

(define (node-edges type nodes)
  "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
returns its edges.  NODES is taken to be the sinks of the global graph."
  (%node-edges type nodes
               (lambda (source target edges)
                 (vhash-consq source target edges))))

(define (node-back-edges type nodes)
  "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
returns its back edges.  NODES is taken to be the sinks of the global graph."
  (%node-edges type nodes
               (lambda (source target edges)
                 (vhash-consq target source edges))))

(define (node-transitive-edges nodes node-edges)
  "Return the list of nodes directly or indirectly connected to NODES
according to the NODE-EDGES procedure.  NODE-EDGES must be a one-argument
procedure that, given a node, returns its list of direct dependents; it is
typically returned by 'node-edges' or 'node-back-edges'."
  (let loop ((nodes   (append-map node-edges nodes))
             (result  '())
             (visited (setq)))
    (match nodes
      (()
       result)
      ((head . tail)
       (if (set-contains? visited head)
           (loop tail result visited)
           (let ((edges (node-edges head)))
             (loop (append edges tail)
                   (cons head result)
                   (set-insert head visited))))))))

\f
;;;
;;; Graphviz export.
;;;

(define-record-type <graph-backend>
  (graph-backend prologue epilogue node edge)
  graph-backend?
  (prologue graph-backend-prologue)
  (epilogue graph-backend-epilogue)
  (node     graph-backend-node)
  (edge     graph-backend-edge))

(define (emit-prologue name port)
  (format port "digraph \"Guix ~a\" {\n"
          name))
(define (emit-epilogue port)
  (display "\n}\n" port))
(define (emit-node id label port)
  (format port "  \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
          id label))
(define (emit-edge id1 id2 port)
  (format port "  \"~a\" -> \"~a\" [color = red];~%"
          id1 id2))

(define %graphviz-backend
  (graph-backend emit-prologue emit-epilogue
                 emit-node emit-edge))

(define* (export-graph sinks port
                       #:key
                       reverse-edges? node-type
                       (backend %graphviz-backend))
  "Write to PORT the representation of the DAG with the given SINKS, using the
given BACKEND.  Use NODE-TYPE to traverse the DAG.  When REVERSE-EDGES? is
true, draw reverse arrows."
  (match backend
    (($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
     (emit-prologue (node-type-name node-type) port)

     (match node-type
       (($ <node-type> node-identifier node-label node-edges)
        (let loop ((nodes   sinks)
                   (visited (set)))
          (match nodes
            (()
             (with-monad %store-monad
               (emit-epilogue port)
               (store-return #t)))
            ((head . tail)
             (mlet %store-monad ((id (node-identifier head)))
               (if (set-contains? visited id)
                   (loop tail visited)
                   (mlet* %store-monad ((dependencies (node-edges head))
                                        (ids          (mapm %store-monad
                                                            node-identifier
                                                            dependencies)))
                     (emit-node id (node-label head) port)
                     (for-each (lambda (dependency dependency-id)
                                 (if reverse-edges?
                                     (emit-edge dependency-id id port)
                                     (emit-edge id dependency-id port)))
                               dependencies ids)
                     (loop (append dependencies tail)
                           (set-insert id visited)))))))))))))

;;; graph.scm ends here
Commit	Line	Data
8fb58371 LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
	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 graph)
	20	#:use-module (guix store)
	21	#:use-module (guix monads)
	22	#:use-module (guix records)
	23	#:use-module (guix sets)
923d846c	24	#:use-module (srfi srfi-1)
8fb58371	25	#:use-module (srfi srfi-9)
923d846c	26	#:use-module (srfi srfi-26)
8fb58371	27	#:use-module (ice-9 match)
923d846c	28	#:use-module (ice-9 vlist)
8fb58371 LC	29	#:export (node-type
	30	node-type?
	31	node-type-identifier
	32	node-type-label
	33	node-type-edges
	34	node-type-convert
	35	node-type-name
	36	node-type-description
	37
923d846c LC	38	node-edges
	39	node-back-edges
	40	node-transitive-edges
	41
8fb58371 LC	42	%graphviz-backend
	43	graph-backend?
	44	graph-backend
	45
	46	export-graph))
	47
	48	;;; Commentary:
	49	;;;
	50	;;; This module provides an abstract way to represent graphs and to manipulate
	51	;;; them. It comes with several such representations for packages,
	52	;;; derivations, and store items. It also provides a generic interface for
	53	;;; exporting graphs in an external format, including a Graphviz
	54	;;; implementation thereof.
	55	;;;
	56	;;; Code:
	57
	58	\f
	59	;;;
	60	;;; Node types.
	61	;;;
	62
	63	(define-record-type* <node-type> node-type make-node-type
	64	node-type?
	65	(identifier node-type-identifier) ;node -> M identifier
	66	(label node-type-label) ;node -> string
	67	(edges node-type-edges) ;node -> M list of nodes
	68	(convert node-type-convert ;package -> M list of nodes
	69	(default (lift1 list %store-monad)))
	70	(name node-type-name) ;string
	71	(description node-type-description)) ;string
	72
923d846c LC	73	(define (%node-edges type nodes cons-edge)
	74	(with-monad %store-monad
	75	(match type
	76	(($ <node-type> identifier label node-edges)
	77	(define (add-edge node edges)
	78	(>>= (node-edges node)
	79	(lambda (nodes)
	80	(return (fold (cut cons-edge node <> <>)
	81	edges nodes)))))
	82
	83	(mlet %store-monad ((edges (foldm %store-monad
	84	add-edge vlist-null nodes)))
	85	(return (lambda (node)
	86	(reverse (vhash-foldq* cons '() node edges)))))))))
	87
	88	(define (node-edges type nodes)
	89	"Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
	90	returns its edges. NODES is taken to be the sinks of the global graph."
	91	(%node-edges type nodes
	92	(lambda (source target edges)
	93	(vhash-consq source target edges))))
	94
	95	(define (node-back-edges type nodes)
	96	"Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
	97	returns its back edges. NODES is taken to be the sinks of the global graph."
	98	(%node-edges type nodes
	99	(lambda (source target edges)
	100	(vhash-consq target source edges))))
	101
	102	(define (node-transitive-edges nodes node-edges)
	103	"Return the list of nodes directly or indirectly connected to NODES
	104	according to the NODE-EDGES procedure. NODE-EDGES must be a one-argument
	105	procedure that, given a node, returns its list of direct dependents; it is
	106	typically returned by 'node-edges' or 'node-back-edges'."
	107	(let loop ((nodes (append-map node-edges nodes))
	108	(result '())
	109	(visited (setq)))
	110	(match nodes
	111	(()
	112	result)
	113	((head . tail)
	114	(if (set-contains? visited head)
	115	(loop tail result visited)
	116	(let ((edges (node-edges head)))
	117	(loop (append edges tail)
	118	(cons head result)
	119	(set-insert head visited))))))))
	120
8fb58371 LC	121	\f
	122	;;;
	123	;;; Graphviz export.
	124	;;;
	125
	126	(define-record-type <graph-backend>
	127	(graph-backend prologue epilogue node edge)
	128	graph-backend?
	129	(prologue graph-backend-prologue)
	130	(epilogue graph-backend-epilogue)
	131	(node graph-backend-node)
	132	(edge graph-backend-edge))
	133
	134	(define (emit-prologue name port)
	135	(format port "digraph \"Guix ~a\" {\n"
	136	name))
	137	(define (emit-epilogue port)
	138	(display "\n}\n" port))
	139	(define (emit-node id label port)
	140	(format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
	141	id label))
	142	(define (emit-edge id1 id2 port)
	143	(format port " \"~a\" -> \"~a\" [color = red];~%"
	144	id1 id2))
	145
	146	(define %graphviz-backend
	147	(graph-backend emit-prologue emit-epilogue
	148	emit-node emit-edge))
	149
	150	(define* (export-graph sinks port
	151	#:key
	152	reverse-edges? node-type
	153	(backend %graphviz-backend))
	154	"Write to PORT the representation of the DAG with the given SINKS, using the
	155	given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is
	156	true, draw reverse arrows."
	157	(match backend
	158	(($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
	159	(emit-prologue (node-type-name node-type) port)
	160
	161	(match node-type
	162	(($ <node-type> node-identifier node-label node-edges)
	163	(let loop ((nodes sinks)
	164	(visited (set)))
	165	(match nodes
	166	(()
	167	(with-monad %store-monad
	168	(emit-epilogue port)
	169	(store-return #t)))
	170	((head . tail)
	171	(mlet %store-monad ((id (node-identifier head)))
	172	(if (set-contains? visited id)
	173	(loop tail visited)
	174	(mlet* %store-monad ((dependencies (node-edges head))
	175	(ids (mapm %store-monad
	176	node-identifier
	177	dependencies)))
	178	(emit-node id (node-label head) port)
	179	(for-each (lambda (dependency dependency-id)
	180	(if reverse-edges?
	181	(emit-edge dependency-id id port)
	182	(emit-edge id dependency-id port)))
	183	dependencies ids)
	184	(loop (append dependencies tail)
185	(set-insert id visited)))))))))))))
186
187	;;; graph.scm ends here