2015-11-21 12:12:02 +00:00
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
2021-01-04 21:10:49 +00:00
|
|
|
|
;;; Copyright © 2015, 2016, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
|
2016-10-21 21:59:00 +00:00
|
|
|
|
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
|
2015-11-21 12:12:02 +00:00
|
|
|
|
;;;
|
|
|
|
|
;;; 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)
|
2016-10-21 22:02:19 +00:00
|
|
|
|
#:use-module (rnrs io ports)
|
2015-11-21 13:48:34 +00:00
|
|
|
|
#:use-module (srfi srfi-1)
|
2015-11-21 12:12:02 +00:00
|
|
|
|
#:use-module (srfi srfi-9)
|
2015-11-21 13:48:34 +00:00
|
|
|
|
#:use-module (srfi srfi-26)
|
2015-11-21 12:12:02 +00:00
|
|
|
|
#:use-module (ice-9 match)
|
2015-11-21 13:48:34 +00:00
|
|
|
|
#:use-module (ice-9 vlist)
|
2015-11-21 12:12:02 +00:00
|
|
|
|
#:export (node-type
|
|
|
|
|
node-type?
|
|
|
|
|
node-type-identifier
|
|
|
|
|
node-type-label
|
|
|
|
|
node-type-edges
|
|
|
|
|
node-type-convert
|
|
|
|
|
node-type-name
|
|
|
|
|
node-type-description
|
|
|
|
|
|
2015-11-21 13:48:34 +00:00
|
|
|
|
node-edges
|
|
|
|
|
node-back-edges
|
2016-05-23 20:31:59 +00:00
|
|
|
|
traverse/depth-first
|
2015-11-21 13:48:34 +00:00
|
|
|
|
node-transitive-edges
|
2016-05-23 21:03:23 +00:00
|
|
|
|
node-reachable-count
|
2020-05-09 22:09:05 +00:00
|
|
|
|
shortest-path
|
2015-11-21 13:48:34 +00:00
|
|
|
|
|
2016-10-21 21:59:00 +00:00
|
|
|
|
%graph-backends
|
2016-10-21 22:02:19 +00:00
|
|
|
|
%d3js-backend
|
2015-11-21 12:12:02 +00:00
|
|
|
|
%graphviz-backend
|
|
|
|
|
graph-backend?
|
|
|
|
|
graph-backend
|
2016-10-20 06:47:03 +00:00
|
|
|
|
graph-backend-name
|
|
|
|
|
graph-backend-description
|
2015-11-21 12:12:02 +00:00
|
|
|
|
|
|
|
|
|
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:
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; 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
|
2016-05-20 15:07:23 +00:00
|
|
|
|
(convert node-type-convert ;any -> M list of nodes
|
2015-11-21 12:12:02 +00:00
|
|
|
|
(default (lift1 list %store-monad)))
|
|
|
|
|
(name node-type-name) ;string
|
|
|
|
|
(description node-type-description)) ;string
|
|
|
|
|
|
2015-11-21 13:48:34 +00:00
|
|
|
|
(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))))
|
|
|
|
|
|
2016-05-23 20:31:59 +00:00
|
|
|
|
(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'."
|
2015-11-21 13:48:34 +00:00
|
|
|
|
(let loop ((nodes (append-map node-edges nodes))
|
2016-05-23 20:31:59 +00:00
|
|
|
|
(result seed)
|
2015-11-21 13:48:34 +00:00
|
|
|
|
(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)
|
2016-05-23 20:31:59 +00:00
|
|
|
|
(proc head result)
|
2015-11-21 13:48:34 +00:00
|
|
|
|
(set-insert head visited))))))))
|
|
|
|
|
|
2016-05-23 20:31:59 +00:00
|
|
|
|
(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))
|
|
|
|
|
|
2016-05-23 21:03:23 +00:00
|
|
|
|
(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))
|
|
|
|
|
0
|
|
|
|
|
nodes node-edges))
|
|
|
|
|
|
2020-05-09 22:09:05 +00:00
|
|
|
|
(define (shortest-path node1 node2 type)
|
2020-10-20 13:38:41 +00:00
|
|
|
|
"Return as a monadic value the shortest path, represented as a list, from
|
2020-05-09 22:09:05 +00:00
|
|
|
|
NODE1 to NODE2 of the given TYPE. Return #f when there is no path."
|
|
|
|
|
(define node-edges
|
|
|
|
|
(node-type-edges type))
|
|
|
|
|
|
|
|
|
|
(define (find-shortest lst)
|
|
|
|
|
;; Return the shortest path among LST, where each path is represented as a
|
|
|
|
|
;; vlist.
|
|
|
|
|
(let loop ((lst lst)
|
|
|
|
|
(best +inf.0)
|
|
|
|
|
(shortest #f))
|
|
|
|
|
(match lst
|
|
|
|
|
(()
|
|
|
|
|
shortest)
|
|
|
|
|
((head . tail)
|
|
|
|
|
(let ((len (vlist-length head)))
|
|
|
|
|
(if (< len best)
|
|
|
|
|
(loop tail len head)
|
|
|
|
|
(loop tail best shortest)))))))
|
|
|
|
|
|
|
|
|
|
(define (find-path node path paths)
|
|
|
|
|
;; Return the a vhash that maps nodes to paths, with each path from the
|
|
|
|
|
;; given node to NODE2.
|
|
|
|
|
(define (augment-paths child paths)
|
|
|
|
|
;; When using %REFERENCE-NODE-TYPE, nodes can contain self references,
|
|
|
|
|
;; hence this test.
|
|
|
|
|
(if (eq? child node)
|
|
|
|
|
(store-return paths)
|
|
|
|
|
(find-path child vlist-null paths)))
|
|
|
|
|
|
|
|
|
|
(cond ((eq? node node2)
|
|
|
|
|
(store-return (vhash-consq node (vlist-cons node path)
|
|
|
|
|
paths)))
|
|
|
|
|
((vhash-assq node paths)
|
|
|
|
|
(store-return paths))
|
|
|
|
|
(else
|
|
|
|
|
;; XXX: We could stop recursing if one if CHILDREN is NODE2, but in
|
|
|
|
|
;; practice it's good enough.
|
|
|
|
|
(mlet* %store-monad ((children (node-edges node))
|
|
|
|
|
(paths (foldm %store-monad
|
|
|
|
|
augment-paths
|
|
|
|
|
paths
|
|
|
|
|
children)))
|
|
|
|
|
(define sub-paths
|
|
|
|
|
(filter-map (lambda (child)
|
|
|
|
|
(match (vhash-assq child paths)
|
|
|
|
|
(#f #f)
|
|
|
|
|
((_ . path) path)))
|
|
|
|
|
children))
|
|
|
|
|
|
|
|
|
|
(match sub-paths
|
|
|
|
|
(()
|
|
|
|
|
(return (vhash-consq node #f paths)))
|
|
|
|
|
(lst
|
|
|
|
|
(return (vhash-consq node
|
|
|
|
|
(vlist-cons node (find-shortest sub-paths))
|
|
|
|
|
paths))))))))
|
|
|
|
|
|
|
|
|
|
(mlet %store-monad ((paths (find-path node1
|
|
|
|
|
(vlist-cons node1 vlist-null)
|
|
|
|
|
vlist-null)))
|
|
|
|
|
(return (match (vhash-assq node1 paths)
|
|
|
|
|
((_ . #f) #f)
|
|
|
|
|
((_ . path) (vlist->list path))))))
|
|
|
|
|
|
2015-11-21 12:12:02 +00:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Graphviz export.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define-record-type <graph-backend>
|
2016-10-20 06:47:03 +00:00
|
|
|
|
(graph-backend name description prologue epilogue node edge)
|
2015-11-21 12:12:02 +00:00
|
|
|
|
graph-backend?
|
2016-10-20 06:47:03 +00:00
|
|
|
|
(name graph-backend-name)
|
|
|
|
|
(description graph-backend-description)
|
|
|
|
|
(prologue graph-backend-prologue)
|
|
|
|
|
(epilogue graph-backend-epilogue)
|
|
|
|
|
(node graph-backend-node)
|
|
|
|
|
(edge graph-backend-edge))
|
2015-11-21 12:12:02 +00:00
|
|
|
|
|
2016-04-02 19:46:26 +00:00
|
|
|
|
(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)))
|
|
|
|
|
|
2015-11-21 12:12:02 +00:00
|
|
|
|
(define (emit-prologue name port)
|
|
|
|
|
(format port "digraph \"Guix ~a\" {\n"
|
|
|
|
|
name))
|
|
|
|
|
(define (emit-epilogue port)
|
|
|
|
|
(display "\n}\n" port))
|
2017-08-24 13:53:57 +00:00
|
|
|
|
(define (emit-node id label port)
|
2020-10-22 08:41:06 +00:00
|
|
|
|
(format port " \"~a\" [label = \"~a\", shape = box, fontname = sans];~%"
|
2017-08-24 13:53:57 +00:00
|
|
|
|
id label))
|
2015-11-21 12:12:02 +00:00
|
|
|
|
(define (emit-edge id1 id2 port)
|
2016-04-02 19:46:26 +00:00
|
|
|
|
(format port " \"~a\" -> \"~a\" [color = ~a];~%"
|
|
|
|
|
id1 id2 (pop-color id1)))
|
2015-11-21 12:12:02 +00:00
|
|
|
|
|
|
|
|
|
(define %graphviz-backend
|
2016-10-20 06:47:03 +00:00
|
|
|
|
(graph-backend "graphviz"
|
|
|
|
|
"Generate graph in DOT format for use with Graphviz."
|
|
|
|
|
emit-prologue emit-epilogue
|
2015-11-21 12:12:02 +00:00
|
|
|
|
emit-node emit-edge))
|
|
|
|
|
|
2016-10-21 22:02:19 +00:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; d3js export.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (emit-d3js-prologue name port)
|
|
|
|
|
(format port "\
|
|
|
|
|
<!DOCTYPE html>
|
|
|
|
|
<html>
|
|
|
|
|
<head>
|
|
|
|
|
<meta charset=\"utf-8\">
|
|
|
|
|
<style>
|
|
|
|
|
text {
|
|
|
|
|
font: 10px sans-serif;
|
|
|
|
|
pointer-events: none;
|
|
|
|
|
}
|
|
|
|
|
</style>
|
|
|
|
|
<script type=\"text/javascript\" src=\"~a\"></script>
|
|
|
|
|
</head>
|
|
|
|
|
<body>
|
|
|
|
|
<script type=\"text/javascript\">
|
|
|
|
|
var nodes = {},
|
|
|
|
|
nodeArray = [],
|
|
|
|
|
links = [];
|
2021-01-04 21:10:49 +00:00
|
|
|
|
" (search-path %load-path "guix/d3.v3.js")))
|
2016-10-21 22:02:19 +00:00
|
|
|
|
|
|
|
|
|
(define (emit-d3js-epilogue port)
|
|
|
|
|
(format port "</script><script type=\"text/javascript\" src=\"~a\"></script></body></html>"
|
2021-01-04 21:10:49 +00:00
|
|
|
|
(search-path %load-path "guix/graph.js")))
|
2016-10-21 22:02:19 +00:00
|
|
|
|
|
2017-08-24 13:53:57 +00:00
|
|
|
|
(define (emit-d3js-node id label port)
|
2016-10-21 22:02:19 +00:00
|
|
|
|
(format port "\
|
|
|
|
|
nodes[\"~a\"] = {\"id\": \"~a\", \"label\": \"~a\", \"index\": nodeArray.length};
|
|
|
|
|
nodeArray.push(nodes[\"~a\"]);~%"
|
2017-08-24 13:53:57 +00:00
|
|
|
|
id id label id))
|
2016-10-21 22:02:19 +00:00
|
|
|
|
|
|
|
|
|
(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))
|
|
|
|
|
|
2017-05-11 14:17:49 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Cypher export.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (emit-cypher-prologue name port)
|
|
|
|
|
(format port ""))
|
|
|
|
|
|
|
|
|
|
(define (emit-cypher-epilogue port)
|
|
|
|
|
(format port ""))
|
|
|
|
|
|
2017-08-24 13:53:57 +00:00
|
|
|
|
(define (emit-cypher-node id label port)
|
2017-05-11 14:17:49 +00:00
|
|
|
|
(format port "MERGE (p:Package { id: ~s }) SET p.name = ~s;~%"
|
2017-08-24 13:53:57 +00:00
|
|
|
|
id label ))
|
2017-05-11 14:17:49 +00:00
|
|
|
|
|
|
|
|
|
(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))
|
|
|
|
|
|
|
|
|
|
|
2016-10-21 21:59:00 +00:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Shared.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define %graph-backends
|
2016-10-21 22:02:19 +00:00
|
|
|
|
(list %graphviz-backend
|
2017-05-11 14:17:49 +00:00
|
|
|
|
%d3js-backend
|
|
|
|
|
%cypher-backend))
|
2016-10-21 21:59:00 +00:00
|
|
|
|
|
2015-11-21 12:12:02 +00:00
|
|
|
|
(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
|
2016-10-20 06:47:03 +00:00
|
|
|
|
(($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge)
|
2015-11-21 12:12:02 +00:00
|
|
|
|
(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)))
|
2017-08-24 13:53:57 +00:00
|
|
|
|
(emit-node id (node-label head) port)
|
2015-11-21 12:12:02 +00:00
|
|
|
|
(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
|