guix/graph.scm

   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>
   4 ;;; Copyright © 2017 Roel Janssen <roel@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix graph)
  22   #:use-module (guix store)
  23   #:use-module (guix monads)
  24   #:use-module (guix records)
  25   #:use-module (guix sets)
  26   #:use-module (guix packages)
  27   #:use-module (rnrs io ports)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-9)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 vlist)
  33   #:export (node-type
  34             node-type?
  35             node-type-identifier
  36             node-type-label
  37             node-type-edges
  38             node-type-convert
  39             node-type-name
  40             node-type-description
  41
  42             node-edges
  43             node-back-edges
  44             traverse/depth-first
  45             node-transitive-edges
  46             node-reachable-count
  47
  48             %graph-backends
  49             %d3js-backend
  50             %graphviz-backend
  51             graph-backend?
  52             graph-backend
  53             graph-backend-name
  54             graph-backend-description
  55
  56             export-graph))
  57
  58 ;;; Commentary:
  59 ;;;
  60 ;;; This module provides an abstract way to represent graphs and to manipulate
  61 ;;; them.  It comes with several such representations for packages,
  62 ;;; derivations, and store items.  It also provides a generic interface for
  63 ;;; exporting graphs in an external format, including a Graphviz
  64 ;;; implementation thereof.
  65 ;;;
  66 ;;; Code:
  67
  68 \f
  69 ;;;
  70 ;;; Node types.
  71 ;;;
  72
  73 (define-record-type* <node-type> node-type make-node-type
  74   node-type?
  75   (identifier  node-type-identifier)              ;node -> M identifier
  76   (label       node-type-label)                   ;node -> string
  77   (edges       node-type-edges)                   ;node -> M list of nodes
  78   (convert     node-type-convert                  ;any -> M list of nodes
  79                (default (lift1 list %store-monad)))
  80   (name        node-type-name)                    ;string
  81   (description node-type-description))            ;string
  82
  83 (define (%node-edges type nodes cons-edge)
  84   (with-monad %store-monad
  85     (match type
  86       (($ <node-type> identifier label node-edges)
  87        (define (add-edge node edges)
  88          (>>= (node-edges node)
  89               (lambda (nodes)
  90                 (return (fold (cut cons-edge node <> <>)
  91                               edges nodes)))))
  92
  93        (mlet %store-monad ((edges (foldm %store-monad
  94                                          add-edge vlist-null nodes)))
  95          (return (lambda (node)
  96                    (reverse (vhash-foldq* cons '() node edges)))))))))
  97
  98 (define (node-edges type nodes)
  99   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
 100 returns its edges.  NODES is taken to be the sinks of the global graph."
 101   (%node-edges type nodes
 102                (lambda (source target edges)
 103                  (vhash-consq source target edges))))
 104
 105 (define (node-back-edges type nodes)
 106   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
 107 returns its back edges.  NODES is taken to be the sinks of the global graph."
 108   (%node-edges type nodes
 109                (lambda (source target edges)
 110                  (vhash-consq target source edges))))
 111
 112 (define (traverse/depth-first proc seed nodes node-edges)
 113   "Do a depth-first traversal of NODES along NODE-EDGES, calling PROC with
 114 each node and the current result, and visiting each reachable node exactly
 115 once.  NODES must be a list of nodes, and NODE-EDGES must be a one-argument
 116 procedure as returned by 'node-edges' or 'node-back-edges'."
 117   (let loop ((nodes   (append-map node-edges nodes))
 118              (result  seed)
 119              (visited (setq)))
 120     (match nodes
 121       (()
 122        result)
 123       ((head . tail)
 124        (if (set-contains? visited head)
 125            (loop tail result visited)
 126            (let ((edges (node-edges head)))
 127              (loop (append edges tail)
 128                    (proc head result)
 129                    (set-insert head visited))))))))
 130
 131 (define (node-transitive-edges nodes node-edges)
 132   "Return the list of nodes directly or indirectly connected to NODES
 133 according to the NODE-EDGES procedure.  NODE-EDGES must be a one-argument
 134 procedure that, given a node, returns its list of direct dependents; it is
 135 typically returned by 'node-edges' or 'node-back-edges'."
 136   (traverse/depth-first cons '() nodes node-edges))
 137
 138 (define (node-reachable-count nodes node-edges)
 139   "Return the number of nodes reachable from NODES along NODE-EDGES."
 140   (traverse/depth-first (lambda (_ count)
 141                           (+ 1 count))
 142                         0
 143                         nodes node-edges))
 144
 145 \f
 146 ;;;
 147 ;;; Graphviz export.
 148 ;;;
 149
 150 (define-record-type <graph-backend>
 151   (graph-backend name description prologue epilogue node edge)
 152   graph-backend?
 153   (name         graph-backend-name)
 154   (description  graph-backend-description)
 155   (prologue     graph-backend-prologue)
 156   (epilogue     graph-backend-epilogue)
 157   (node         graph-backend-node)
 158   (edge         graph-backend-edge))
 159
 160 (define %colors
 161   ;; See colortbl.h in Graphviz.
 162   #("red" "magenta" "blue" "cyan3" "darkseagreen"
 163     "peachpuff4" "darkviolet" "dimgrey" "darkgoldenrod"))
 164
 165 (define (pop-color hint)
 166   "Return a Graphviz color based on HINT, an arbitrary object."
 167   (let ((index (hash hint (vector-length %colors))))
 168     (vector-ref %colors index)))
 169
 170 (define (emit-prologue name port)
 171   (format port "digraph \"Guix ~a\" {\n"
 172           name))
 173 (define (emit-epilogue port)
 174   (display "\n}\n" port))
 175 (define (emit-node id node port)
 176   (format port "  \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
 177           id (package-full-name node)))
 178 (define (emit-edge id1 id2 port)
 179   (format port "  \"~a\" -> \"~a\" [color = ~a];~%"
 180           id1 id2 (pop-color id1)))
 181
 182 (define %graphviz-backend
 183   (graph-backend "graphviz"
 184                  "Generate graph in DOT format for use with Graphviz."
 185                  emit-prologue emit-epilogue
 186                  emit-node emit-edge))
 187
 188 \f
 189 ;;;
 190 ;;; d3js export.
 191 ;;;
 192
 193 (define (emit-d3js-prologue name port)
 194   (format port "\
 195 <!DOCTYPE html>
 196 <html>
 197   <head>
 198     <meta charset=\"utf-8\">
 199     <style>
 200 text {
 201   font: 10px sans-serif;
 202   pointer-events: none;
 203 }
 204     </style>
 205     <script type=\"text/javascript\" src=\"~a\"></script>
 206   </head>
 207   <body>
 208     <script type=\"text/javascript\">
 209 var nodes = {},
 210     nodeArray = [],
 211     links = [];
 212 " (search-path %load-path "d3.v3.js")))
 213
 214 (define (emit-d3js-epilogue port)
 215   (format port "</script><script type=\"text/javascript\" src=\"~a\"></script></body></html>"
 216           (search-path %load-path "graph.js")))
 217
 218 (define (emit-d3js-node id node port)
 219   (format port "\
 220 nodes[\"~a\"] = {\"id\": \"~a\", \"label\": \"~a\", \"index\": nodeArray.length};
 221 nodeArray.push(nodes[\"~a\"]);~%"
 222           id id (package-full-name node) id))
 223
 224 (define (emit-d3js-edge id1 id2 port)
 225   (format port "links.push({\"source\": \"~a\", \"target\": \"~a\"});~%"
 226           id1 id2))
 227
 228 (define %d3js-backend
 229   (graph-backend "d3js"
 230                  "Generate chord diagrams with d3js."
 231                  emit-d3js-prologue emit-d3js-epilogue
 232                  emit-d3js-node emit-d3js-edge))
 233
 234
 235 \f
 236 ;;;
 237 ;;; Cypher export.
 238 ;;;
 239
 240 (define (emit-cypher-prologue name port)
 241   (format port ""))
 242
 243 (define (emit-cypher-epilogue port)
 244   (format port ""))
 245
 246 (define (emit-cypher-node id node port)
 247   (format port "MERGE (p:Package { id: ~s }) SET p.name = ~s;~%"
 248           id (package-name node)))
 249
 250 (define (emit-cypher-edge id1 id2 port)
 251   (format port "MERGE (a:Package { id: ~s });~%" id1)
 252   (format port "MERGE (b:Package { id: ~s });~%" id2)
 253   (format port "MATCH (a:Package { id: ~s }), (b:Package { id: ~s }) CREATE UNIQUE (a)-[:NEEDS]->(b);~%"
 254           id1 id2))
 255
 256 (define %cypher-backend
 257   (graph-backend "cypher"
 258                  "Generate Cypher queries."
 259                  emit-cypher-prologue emit-cypher-epilogue
 260                  emit-cypher-node emit-cypher-edge))
 261
 262
 263 \f
 264 ;;;
 265 ;;; Shared.
 266 ;;;
 267
 268 (define %graph-backends
 269   (list %graphviz-backend
 270         %d3js-backend
 271         %cypher-backend))
 272
 273 (define* (export-graph sinks port
 274                        #:key
 275                        reverse-edges? node-type
 276                        (backend %graphviz-backend))
 277   "Write to PORT the representation of the DAG with the given SINKS, using the
 278 given BACKEND.  Use NODE-TYPE to traverse the DAG.  When REVERSE-EDGES? is
 279 true, draw reverse arrows."
 280   (match backend
 281     (($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge)
 282      (emit-prologue (node-type-name node-type) port)
 283
 284      (match node-type
 285        (($ <node-type> node-identifier node-label node-edges)
 286         (let loop ((nodes   sinks)
 287                    (visited (set)))
 288           (match nodes
 289             (()
 290              (with-monad %store-monad
 291                (emit-epilogue port)
 292                (store-return #t)))
 293             ((head . tail)
 294              (mlet %store-monad ((id (node-identifier head)))
 295                (if (set-contains? visited id)
 296                    (loop tail visited)
 297                    (mlet* %store-monad ((dependencies (node-edges head))
 298                                         (ids          (mapm %store-monad
 299                                                             node-identifier
 300                                                             dependencies)))
 301                      (emit-node id head port)
 302                      (for-each (lambda (dependency dependency-id)
 303                                  (if reverse-edges?
 304                                      (emit-edge dependency-id id port)
 305                                      (emit-edge id dependency-id port)))
 306                                dependencies ids)
 307                      (loop (append dependencies tail)
 308                            (set-insert id visited)))))))))))))
 309
 310 ;;; graph.scm ends here