guix/graph.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   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.
  11 ;;;
  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.
  16 ;;;
  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/>.
  19
  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 (rnrs io ports)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-9)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (ice-9 match)
  30   #:use-module (ice-9 vlist)
  31   #:export (node-type
  32             node-type?
  33             node-type-identifier
  34             node-type-label
  35             node-type-edges
  36             node-type-convert
  37             node-type-name
  38             node-type-description
  39
  40             node-edges
  41             node-back-edges
  42             traverse/depth-first
  43             node-transitive-edges
  44             node-reachable-count
  45             shortest-path
  46
  47             %graph-backends
  48             %d3js-backend
  49             %graphviz-backend
  50             graph-backend?
  51             graph-backend
  52             graph-backend-name
  53             graph-backend-description
  54
  55             export-graph))
  56
  57 ;;; Commentary:
  58 ;;;
  59 ;;; This module provides an abstract way to represent graphs and to manipulate
  60 ;;; them.  It comes with several such representations for packages,
  61 ;;; derivations, and store items.  It also provides a generic interface for
  62 ;;; exporting graphs in an external format, including a Graphviz
  63 ;;; implementation thereof.
  64 ;;;
  65 ;;; Code:
  66
  67 \f
  68 ;;;
  69 ;;; Node types.
  70 ;;;
  71
  72 (define-record-type* <node-type> node-type make-node-type
  73   node-type?
  74   (identifier  node-type-identifier)              ;node -> M identifier
  75   (label       node-type-label)                   ;node -> string
  76   (edges       node-type-edges)                   ;node -> M list of nodes
  77   (convert     node-type-convert                  ;any -> M list of nodes
  78                (default (lift1 list %store-monad)))
  79   (name        node-type-name)                    ;string
  80   (description node-type-description))            ;string
  81
  82 (define (%node-edges type nodes cons-edge)
  83   (with-monad %store-monad
  84     (match type
  85       (($ <node-type> identifier label node-edges)
  86        (define (add-edge node edges)
  87          (>>= (node-edges node)
  88               (lambda (nodes)
  89                 (return (fold (cut cons-edge node <> <>)
  90                               edges nodes)))))
  91
  92        (mlet %store-monad ((edges (foldm %store-monad
  93                                          add-edge vlist-null nodes)))
  94          (return (lambda (node)
  95                    (reverse (vhash-foldq* cons '() node edges)))))))))
  96
  97 (define (node-edges type nodes)
  98   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
  99 returns its edges.  NODES is taken to be the sinks of the global graph."
 100   (%node-edges type nodes
 101                (lambda (source target edges)
 102                  (vhash-consq source target edges))))
 103
 104 (define (node-back-edges type nodes)
 105   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
 106 returns its back edges.  NODES is taken to be the sinks of the global graph."
 107   (%node-edges type nodes
 108                (lambda (source target edges)
 109                  (vhash-consq target source edges))))
 110
 111 (define (traverse/depth-first proc seed nodes node-edges)
 112   "Do a depth-first traversal of NODES along NODE-EDGES, calling PROC with
 113 each node and the current result, and visiting each reachable node exactly
 114 once.  NODES must be a list of nodes, and NODE-EDGES must be a one-argument
 115 procedure as returned by 'node-edges' or 'node-back-edges'."
 116   (let loop ((nodes   (append-map node-edges nodes))
 117              (result  seed)
 118              (visited (setq)))
 119     (match nodes
 120       (()
 121        result)
 122       ((head . tail)
 123        (if (set-contains? visited head)
 124            (loop tail result visited)
 125            (let ((edges (node-edges head)))
 126              (loop (append edges tail)
 127                    (proc head result)
 128                    (set-insert head visited))))))))
 129
 130 (define (node-transitive-edges nodes node-edges)
 131   "Return the list of nodes directly or indirectly connected to NODES
 132 according to the NODE-EDGES procedure.  NODE-EDGES must be a one-argument
 133 procedure that, given a node, returns its list of direct dependents; it is
 134 typically returned by 'node-edges' or 'node-back-edges'."
 135   (traverse/depth-first cons '() nodes node-edges))
 136
 137 (define (node-reachable-count nodes node-edges)
 138   "Return the number of nodes reachable from NODES along NODE-EDGES."
 139   (traverse/depth-first (lambda (_ count)
 140                           (+ 1 count))
 141                         0
 142                         nodes node-edges))
 143
 144 (define (shortest-path node1 node2 type)
 145   "Return as a monadic value the shorted path, represented as a list, from
 146 NODE1 to NODE2 of the given TYPE.  Return #f when there is no path."
 147   (define node-edges
 148     (node-type-edges type))
 149
 150   (define (find-shortest lst)
 151     ;; Return the shortest path among LST, where each path is represented as a
 152     ;; vlist.
 153     (let loop ((lst lst)
 154                (best +inf.0)
 155                (shortest #f))
 156       (match lst
 157         (()
 158          shortest)
 159         ((head . tail)
 160          (let ((len (vlist-length head)))
 161            (if (< len best)
 162                (loop tail len head)
 163                (loop tail best shortest)))))))
 164
 165   (define (find-path node path paths)
 166     ;; Return the a vhash that maps nodes to paths, with each path from the
 167     ;; given node to NODE2.
 168     (define (augment-paths child paths)
 169       ;; When using %REFERENCE-NODE-TYPE, nodes can contain self references,
 170       ;; hence this test.
 171       (if (eq? child node)
 172           (store-return paths)
 173           (find-path child vlist-null paths)))
 174
 175     (cond ((eq? node node2)
 176            (store-return (vhash-consq node (vlist-cons node path)
 177                                       paths)))
 178           ((vhash-assq node paths)
 179            (store-return paths))
 180           (else
 181            ;; XXX: We could stop recursing if one if CHILDREN is NODE2, but in
 182            ;; practice it's good enough.
 183            (mlet* %store-monad ((children (node-edges node))
 184                                 (paths    (foldm %store-monad
 185                                                  augment-paths
 186                                                  paths
 187                                                  children)))
 188              (define sub-paths
 189                (filter-map (lambda (child)
 190                              (match (vhash-assq child paths)
 191                                (#f #f)
 192                                ((_ . path) path)))
 193                            children))
 194
 195              (match sub-paths
 196                (()
 197                 (return (vhash-consq node #f paths)))
 198                (lst
 199                 (return (vhash-consq node
 200                                      (vlist-cons node (find-shortest sub-paths))
 201                                      paths))))))))
 202
 203   (mlet %store-monad ((paths (find-path node1
 204                                         (vlist-cons node1 vlist-null)
 205                                         vlist-null)))
 206     (return (match (vhash-assq node1 paths)
 207               ((_ . #f) #f)
 208               ((_ . path) (vlist->list path))))))
 209
 210 \f
 211 ;;;
 212 ;;; Graphviz export.
 213 ;;;
 214
 215 (define-record-type <graph-backend>
 216   (graph-backend name description prologue epilogue node edge)
 217   graph-backend?
 218   (name         graph-backend-name)
 219   (description  graph-backend-description)
 220   (prologue     graph-backend-prologue)
 221   (epilogue     graph-backend-epilogue)
 222   (node         graph-backend-node)
 223   (edge         graph-backend-edge))
 224
 225 (define %colors
 226   ;; See colortbl.h in Graphviz.
 227   #("red" "magenta" "blue" "cyan3" "darkseagreen"
 228     "peachpuff4" "darkviolet" "dimgrey" "darkgoldenrod"))
 229
 230 (define (pop-color hint)
 231   "Return a Graphviz color based on HINT, an arbitrary object."
 232   (let ((index (hash hint (vector-length %colors))))
 233     (vector-ref %colors index)))
 234
 235 (define (emit-prologue name port)
 236   (format port "digraph \"Guix ~a\" {\n"
 237           name))
 238 (define (emit-epilogue port)
 239   (display "\n}\n" port))
 240 (define (emit-node id label port)
 241   (format port "  \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
 242           id label))
 243 (define (emit-edge id1 id2 port)
 244   (format port "  \"~a\" -> \"~a\" [color = ~a];~%"
 245           id1 id2 (pop-color id1)))
 246
 247 (define %graphviz-backend
 248   (graph-backend "graphviz"
 249                  "Generate graph in DOT format for use with Graphviz."
 250                  emit-prologue emit-epilogue
 251                  emit-node emit-edge))
 252
 253 \f
 254 ;;;
 255 ;;; d3js export.
 256 ;;;
 257
 258 (define (emit-d3js-prologue name port)
 259   (format port "\
 260 <!DOCTYPE html>
 261 <html>
 262   <head>
 263     <meta charset=\"utf-8\">
 264     <style>
 265 text {
 266   font: 10px sans-serif;
 267   pointer-events: none;
 268 }
 269     </style>
 270     <script type=\"text/javascript\" src=\"~a\"></script>
 271   </head>
 272   <body>
 273     <script type=\"text/javascript\">
 274 var nodes = {},
 275     nodeArray = [],
 276     links = [];
 277 " (search-path %load-path "d3.v3.js")))
 278
 279 (define (emit-d3js-epilogue port)
 280   (format port "</script><script type=\"text/javascript\" src=\"~a\"></script></body></html>"
 281           (search-path %load-path "graph.js")))
 282
 283 (define (emit-d3js-node id label port)
 284   (format port "\
 285 nodes[\"~a\"] = {\"id\": \"~a\", \"label\": \"~a\", \"index\": nodeArray.length};
 286 nodeArray.push(nodes[\"~a\"]);~%"
 287           id id label id))
 288
 289 (define (emit-d3js-edge id1 id2 port)
 290   (format port "links.push({\"source\": \"~a\", \"target\": \"~a\"});~%"
 291           id1 id2))
 292
 293 (define %d3js-backend
 294   (graph-backend "d3js"
 295                  "Generate chord diagrams with d3js."
 296                  emit-d3js-prologue emit-d3js-epilogue
 297                  emit-d3js-node emit-d3js-edge))
 298
 299
 300 \f
 301 ;;;
 302 ;;; Cypher export.
 303 ;;;
 304
 305 (define (emit-cypher-prologue name port)
 306   (format port ""))
 307
 308 (define (emit-cypher-epilogue port)
 309   (format port ""))
 310
 311 (define (emit-cypher-node id label port)
 312   (format port "MERGE (p:Package { id: ~s }) SET p.name = ~s;~%"
 313           id label ))
 314
 315 (define (emit-cypher-edge id1 id2 port)
 316   (format port "MERGE (a:Package { id: ~s });~%" id1)
 317   (format port "MERGE (b:Package { id: ~s });~%" id2)
 318   (format port "MATCH (a:Package { id: ~s }), (b:Package { id: ~s }) CREATE UNIQUE (a)-[:NEEDS]->(b);~%"
 319           id1 id2))
 320
 321 (define %cypher-backend
 322   (graph-backend "cypher"
 323                  "Generate Cypher queries."
 324                  emit-cypher-prologue emit-cypher-epilogue
 325                  emit-cypher-node emit-cypher-edge))
 326
 327
 328 \f
 329 ;;;
 330 ;;; Shared.
 331 ;;;
 332
 333 (define %graph-backends
 334   (list %graphviz-backend
 335         %d3js-backend
 336         %cypher-backend))
 337
 338 (define* (export-graph sinks port
 339                        #:key
 340                        reverse-edges? node-type
 341                        (backend %graphviz-backend))
 342   "Write to PORT the representation of the DAG with the given SINKS, using the
 343 given BACKEND.  Use NODE-TYPE to traverse the DAG.  When REVERSE-EDGES? is
 344 true, draw reverse arrows."
 345   (match backend
 346     (($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge)
 347      (emit-prologue (node-type-name node-type) port)
 348
 349      (match node-type
 350        (($ <node-type> node-identifier node-label node-edges)
 351         (let loop ((nodes   sinks)
 352                    (visited (set)))
 353           (match nodes
 354             (()
 355              (with-monad %store-monad
 356                (emit-epilogue port)
 357                (store-return #t)))
 358             ((head . tail)
 359              (mlet %store-monad ((id (node-identifier head)))
 360                (if (set-contains? visited id)
 361                    (loop tail visited)
 362                    (mlet* %store-monad ((dependencies (node-edges head))
 363                                         (ids          (mapm %store-monad
 364                                                             node-identifier
 365                                                             dependencies)))
 366                      (emit-node id (node-label head) port)
 367                      (for-each (lambda (dependency dependency-id)
 368                                  (if reverse-edges?
 369                                      (emit-edge dependency-id id port)
 370                                      (emit-edge id dependency-id port)))
 371                                dependencies ids)
 372                      (loop (append dependencies tail)
 373                            (set-insert id visited)))))))))))))
 374
 375 ;;; graph.scm ends here