guix/graph.scm

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