1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (guix graph)
21 #:use-module (guix store)
22 #:use-module (guix monads)
23 #:use-module (guix records)
24 #:use-module (guix sets)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-9)
27 #:use-module (srfi srfi-26)
28 #:use-module (ice-9 match)
29 #:use-module (ice-9 vlist)
50 graph-backend-description
56 ;;; This module provides an abstract way to represent graphs and to manipulate
57 ;;; them. It comes with several such representations for packages,
58 ;;; derivations, and store items. It also provides a generic interface for
59 ;;; exporting graphs in an external format, including a Graphviz
60 ;;; implementation thereof.
69 (define-record-type* <node-type> node-type make-node-type
71 (identifier node-type-identifier) ;node -> M identifier
72 (label node-type-label) ;node -> string
73 (edges node-type-edges) ;node -> M list of nodes
74 (convert node-type-convert ;any -> M list of nodes
75 (default (lift1 list %store-monad)))
76 (name node-type-name) ;string
77 (description node-type-description)) ;string
79 (define (%node-edges type nodes cons-edge)
80 (with-monad %store-monad
82 (($ <node-type> identifier label node-edges)
83 (define (add-edge node edges)
84 (>>= (node-edges node)
86 (return (fold (cut cons-edge node <> <>)
89 (mlet %store-monad ((edges (foldm %store-monad
90 add-edge vlist-null nodes)))
91 (return (lambda (node)
92 (reverse (vhash-foldq* cons '() node edges)))))))))
94 (define (node-edges type nodes)
95 "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
96 returns its edges. NODES is taken to be the sinks of the global graph."
97 (%node-edges type nodes
98 (lambda (source target edges)
99 (vhash-consq source target edges))))
101 (define (node-back-edges type nodes)
102 "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
103 returns its back edges. NODES is taken to be the sinks of the global graph."
104 (%node-edges type nodes
105 (lambda (source target edges)
106 (vhash-consq target source edges))))
108 (define (traverse/depth-first proc seed nodes node-edges)
109 "Do a depth-first traversal of NODES along NODE-EDGES, calling PROC with
110 each node and the current result, and visiting each reachable node exactly
111 once. NODES must be a list of nodes, and NODE-EDGES must be a one-argument
112 procedure as returned by 'node-edges' or 'node-back-edges'."
113 (let loop ((nodes (append-map node-edges nodes))
120 (if (set-contains? visited head)
121 (loop tail result visited)
122 (let ((edges (node-edges head)))
123 (loop (append edges tail)
125 (set-insert head visited))))))))
127 (define (node-transitive-edges nodes node-edges)
128 "Return the list of nodes directly or indirectly connected to NODES
129 according to the NODE-EDGES procedure. NODE-EDGES must be a one-argument
130 procedure that, given a node, returns its list of direct dependents; it is
131 typically returned by 'node-edges' or 'node-back-edges'."
132 (traverse/depth-first cons '() nodes node-edges))
134 (define (node-reachable-count nodes node-edges)
135 "Return the number of nodes reachable from NODES along NODE-EDGES."
136 (traverse/depth-first (lambda (_ count)
146 (define-record-type <graph-backend>
147 (graph-backend name description prologue epilogue node edge)
149 (name graph-backend-name)
150 (description graph-backend-description)
151 (prologue graph-backend-prologue)
152 (epilogue graph-backend-epilogue)
153 (node graph-backend-node)
154 (edge graph-backend-edge))
157 ;; See colortbl.h in Graphviz.
158 #("red" "magenta" "blue" "cyan3" "darkseagreen"
159 "peachpuff4" "darkviolet" "dimgrey" "darkgoldenrod"))
161 (define (pop-color hint)
162 "Return a Graphviz color based on HINT, an arbitrary object."
163 (let ((index (hash hint (vector-length %colors))))
164 (vector-ref %colors index)))
166 (define (emit-prologue name port)
167 (format port "digraph \"Guix ~a\" {\n"
169 (define (emit-epilogue port)
170 (display "\n}\n" port))
171 (define (emit-node id label port)
172 (format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
174 (define (emit-edge id1 id2 port)
175 (format port " \"~a\" -> \"~a\" [color = ~a];~%"
176 id1 id2 (pop-color id1)))
178 (define %graphviz-backend
179 (graph-backend "graphviz"
180 "Generate graph in DOT format for use with Graphviz."
181 emit-prologue emit-epilogue
182 emit-node emit-edge))
189 (define %graph-backends
190 (list %graphviz-backend))
192 (define* (export-graph sinks port
194 reverse-edges? node-type
195 (backend %graphviz-backend))
196 "Write to PORT the representation of the DAG with the given SINKS, using the
197 given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is
198 true, draw reverse arrows."
200 (($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge)
201 (emit-prologue (node-type-name node-type) port)
204 (($ <node-type> node-identifier node-label node-edges)
205 (let loop ((nodes sinks)
209 (with-monad %store-monad
213 (mlet %store-monad ((id (node-identifier head)))
214 (if (set-contains? visited id)
216 (mlet* %store-monad ((dependencies (node-edges head))
217 (ids (mapm %store-monad
220 (emit-node id (node-label head) port)
221 (for-each (lambda (dependency dependency-id)
223 (emit-edge dependency-id id port)
224 (emit-edge id dependency-id port)))
226 (loop (append dependencies tail)
227 (set-insert id visited)))))))))))))
229 ;;; graph.scm ends here