Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

308 lines
10 KiB

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; 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
;;; 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 (rnrs io ports)
#: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
;;; 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:
;;; Node types.
(define-record-type* <node-type> node-type make-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 ;any -> 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 (traverse/depth-first proc seed nodes node-edges)
"Do a depth-first traversal of NODES along NODE-EDGES, calling PROC with
each node and the current result, and visiting each reachable node exactly
once. NODES must be a list of nodes, and NODE-EDGES must be a one-argument
procedure as returned by 'node-edges' or 'node-back-edges'."
(let loop ((nodes (append-map node-edges nodes))
(result seed)
(visited (setq)))
(match nodes
((head . tail)
(if (set-contains? visited head)
(loop tail result visited)
(let ((edges (node-edges head)))
(loop (append edges tail)
(proc head result)
(set-insert head visited))))))))
(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'."
(traverse/depth-first cons '() nodes node-edges))
(define (node-reachable-count nodes node-edges)
"Return the number of nodes reachable from NODES along NODE-EDGES."
(traverse/depth-first (lambda (_ count)
(+ 1 count))
nodes node-edges))
;;; Graphviz export.
(define-record-type <graph-backend>
(graph-backend name description prologue epilogue node edge)
(name graph-backend-name)
(description graph-backend-description)
(prologue graph-backend-prologue)
(epilogue graph-backend-epilogue)
(node graph-backend-node)
(edge graph-backend-edge))
(define %colors
;; See colortbl.h in Graphviz.
#("red" "magenta" "blue" "cyan3" "darkseagreen"
"peachpuff4" "darkviolet" "dimgrey" "darkgoldenrod"))
(define (pop-color hint)
"Return a Graphviz color based on HINT, an arbitrary object."
(let ((index (hash hint (vector-length %colors))))
(vector-ref %colors index)))
(define (emit-prologue name port)
(format port "digraph \"Guix ~a\" {\n"
(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 = ~a];~%"
id1 id2 (pop-color id1)))
(define %graphviz-backend
(graph-backend "graphviz"
"Generate graph in DOT format for use with Graphviz."
emit-prologue emit-epilogue
emit-node emit-edge))
;;; d3js export.
(define (emit-d3js-prologue name port)
(format port "\
<!DOCTYPE html>
<meta charset=\"utf-8\">
text {
font: 10px sans-serif;
pointer-events: none;
<script type=\"text/javascript\" src=\"~a\"></script>
<script type=\"text/javascript\">
var nodes = {},
nodeArray = [],
links = [];
" (search-path %load-path "d3.v3.js")))
(define (emit-d3js-epilogue port)
(format port "</script><script type=\"text/javascript\" src=\"~a\"></script></body></html>"
(search-path %load-path "graph.js")))
(define (emit-d3js-node id label port)
(format port "\
nodes[\"~a\"] = {\"id\": \"~a\", \"label\": \"~a\", \"index\": nodeArray.length};
id id label id))
(define (emit-d3js-edge id1 id2 port)
(format port "links.push({\"source\": \"~a\", \"target\": \"~a\"});~%"
id1 id2))
(define %d3js-backend
(graph-backend "d3js"
"Generate chord diagrams with d3js."
emit-d3js-prologue emit-d3js-epilogue
emit-d3js-node emit-d3js-edge))
;;; Cypher export.
(define (emit-cypher-prologue name port)
(format port ""))
(define (emit-cypher-epilogue port)
(format port ""))
(define (emit-cypher-node id label port)
(format port "MERGE (p:Package { id: ~s }) SET p.name = ~s;~%"
id label ))
(define (emit-cypher-edge id1 id2 port)
(format port "MERGE (a:Package { id: ~s });~%" id1)
(format port "MERGE (b:Package { id: ~s });~%" id2)
(format port "MATCH (a:Package { id: ~s }), (b:Package { id: ~s }) CREATE UNIQUE (a)-[:NEEDS]->(b);~%"
id1 id2))
(define %cypher-backend
(graph-backend "cypher"
"Generate Cypher queries."
emit-cypher-prologue emit-cypher-epilogue
emit-cypher-node emit-cypher-edge))
;;; Shared.
(define %graph-backends
(list %graphviz-backend
(define* (export-graph sinks port
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
(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