;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
#: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)
node-edges
node-back-edges
+ traverse/depth-first
node-transitive-edges
+ node-reachable-count
+ shortest-path
+ %graph-backends
+ %d3js-backend
%graphviz-backend
graph-backend?
graph-backend
+ graph-backend-name
+ graph-backend-description
export-graph))
(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
+ (convert node-type-convert ;any -> M list of nodes
(default (lift1 list %store-monad)))
(name node-type-name) ;string
(description node-type-description)) ;string
(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'."
+(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 '())
+ (result seed)
(visited (setq)))
(match nodes
(()
(loop tail result visited)
(let ((edges (node-edges head)))
(loop (append edges tail)
- (cons head result)
+ (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))
+ 0
+ nodes node-edges))
+
+(define (shortest-path node1 node2 type)
+ "Return as a monadic value the shorted path, represented as a list, from
+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))))))
+
\f
;;;
;;; Graphviz export.
;;;
(define-record-type <graph-backend>
- (graph-backend prologue epilogue node edge)
+ (graph-backend name description prologue epilogue node edge)
graph-backend?
- (prologue graph-backend-prologue)
- (epilogue graph-backend-epilogue)
- (node graph-backend-node)
- (edge graph-backend-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"
(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))
+ (format port " \"~a\" -> \"~a\" [color = ~a];~%"
+ id1 id2 (pop-color id1)))
(define %graphviz-backend
- (graph-backend emit-prologue emit-epilogue
+ (graph-backend "graphviz"
+ "Generate graph in DOT format for use with Graphviz."
+ emit-prologue emit-epilogue
emit-node emit-edge))
+\f
+;;;
+;;; 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 = [];
+" (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};
+nodeArray.push(nodes[\"~a\"]);~%"
+ 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))
+
+
+\f
+;;;
+;;; 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))
+
+
+\f
+;;;
+;;; Shared.
+;;;
+
+(define %graph-backends
+ (list %graphviz-backend
+ %d3js-backend
+ %cypher-backend))
+
(define* (export-graph sinks port
#:key
reverse-edges? node-type
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)
+ (($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge)
(emit-prologue (node-type-name node-type) port)
(match node-type
HCoop / jackhill / guix / guix.git / blobdiff