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 ;;;
   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
  46             %graph-backends
  47             %d3js-backend
  48             %graphviz-backend
  49             graph-backend?
  50             graph-backend
  51             graph-backend-name
  52             graph-backend-description
  53
  54             export-graph))
  55
  56 ;;; Commentary:
  57 ;;;
  58 ;;; This module provides an abstract way to represent graphs and to manipulate
  59 ;;; them.  It comes with several such representations for packages,
  60 ;;; derivations, and store items.  It also provides a generic interface for
  61 ;;; exporting graphs in an external format, including a Graphviz
  62 ;;; implementation thereof.
  63 ;;;
  64 ;;; Code:
  65
  66 \f
  67 ;;;
  68 ;;; Node types.
  69 ;;;
  70
  71 (define-record-type* <node-type> node-type make-node-type
  72   node-type?
  73   (identifier  node-type-identifier)              ;node -> M identifier
  74   (label       node-type-label)                   ;node -> string
  75   (edges       node-type-edges)                   ;node -> M list of nodes
  76   (convert     node-type-convert                  ;any -> M list of nodes
  77                (default (lift1 list %store-monad)))
  78   (name        node-type-name)                    ;string
  79   (description node-type-description))            ;string
  80
  81 (define (%node-edges type nodes cons-edge)
  82   (with-monad %store-monad
  83     (match type
  84       (($ <node-type> identifier label node-edges)
  85        (define (add-edge node edges)
  86          (>>= (node-edges node)
  87               (lambda (nodes)
  88                 (return (fold (cut cons-edge node <> <>)
  89                               edges nodes)))))
  90
  91        (mlet %store-monad ((edges (foldm %store-monad
  92                                          add-edge vlist-null nodes)))
  93          (return (lambda (node)
  94                    (reverse (vhash-foldq* cons '() node edges)))))))))
  95
  96 (define (node-edges type nodes)
  97   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
  98 returns its edges.  NODES is taken to be the sinks of the global graph."
  99   (%node-edges type nodes
 100                (lambda (source target edges)
 101                  (vhash-consq source target edges))))
 102
 103 (define (node-back-edges type nodes)
 104   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
 105 returns its back edges.  NODES is taken to be the sinks of the global graph."
 106   (%node-edges type nodes
 107                (lambda (source target edges)
 108                  (vhash-consq target source edges))))
 109
 110 (define (traverse/depth-first proc seed nodes node-edges)
 111   "Do a depth-first traversal of NODES along NODE-EDGES, calling PROC with
 112 each node and the current result, and visiting each reachable node exactly
 113 once.  NODES must be a list of nodes, and NODE-EDGES must be a one-argument
 114 procedure as returned by 'node-edges' or 'node-back-edges'."
 115   (let loop ((nodes   (append-map node-edges nodes))
 116              (result  seed)
 117              (visited (setq)))
 118     (match nodes
 119       (()
 120        result)
 121       ((head . tail)
 122        (if (set-contains? visited head)
 123            (loop tail result visited)
 124            (let ((edges (node-edges head)))
 125              (loop (append edges tail)
 126                    (proc head result)
 127                    (set-insert head visited))))))))
 128
 129 (define (node-transitive-edges nodes node-edges)
 130   "Return the list of nodes directly or indirectly connected to NODES
 131 according to the NODE-EDGES procedure.  NODE-EDGES must be a one-argument
 132 procedure that, given a node, returns its list of direct dependents; it is
 133 typically returned by 'node-edges' or 'node-back-edges'."
 134   (traverse/depth-first cons '() nodes node-edges))
 135
 136 (define (node-reachable-count nodes node-edges)
 137   "Return the number of nodes reachable from NODES along NODE-EDGES."
 138   (traverse/depth-first (lambda (_ count)
 139                           (+ 1 count))
 140                         0
 141                         nodes node-edges))
 142
 143 \f
 144 ;;;
 145 ;;; Graphviz export.
 146 ;;;
 147
 148 (define-record-type <graph-backend>
 149   (graph-backend name description prologue epilogue node edge)
 150   graph-backend?
 151   (name         graph-backend-name)
 152   (description  graph-backend-description)
 153   (prologue     graph-backend-prologue)
 154   (epilogue     graph-backend-epilogue)
 155   (node         graph-backend-node)
 156   (edge         graph-backend-edge))
 157
 158 (define %colors
 159   ;; See colortbl.h in Graphviz.
 160   #("red" "magenta" "blue" "cyan3" "darkseagreen"
 161     "peachpuff4" "darkviolet" "dimgrey" "darkgoldenrod"))
 162
 163 (define (pop-color hint)
 164   "Return a Graphviz color based on HINT, an arbitrary object."
 165   (let ((index (hash hint (vector-length %colors))))
 166     (vector-ref %colors index)))
 167
 168 (define (emit-prologue name port)
 169   (format port "digraph \"Guix ~a\" {\n"
 170           name))
 171 (define (emit-epilogue port)
 172   (display "\n}\n" port))
 173 (define (emit-node id label port)
 174   (format port "  \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
 175           id label))
 176 (define (emit-edge id1 id2 port)
 177   (format port "  \"~a\" -> \"~a\" [color = ~a];~%"
 178           id1 id2 (pop-color id1)))
 179
 180 (define %graphviz-backend
 181   (graph-backend "graphviz"
 182                  "Generate graph in DOT format for use with Graphviz."
 183                  emit-prologue emit-epilogue
 184                  emit-node emit-edge))
 185
 186 \f
 187 ;;;
 188 ;;; d3js export.
 189 ;;;
 190
 191 (define (emit-d3js-prologue name port)
 192   (format port "\
 193 <!DOCTYPE html>
 194 <html>
 195   <head>
 196     <meta charset=\"utf-8\">
 197     <style>
 198 text {
 199   font: 10px sans-serif;
 200   pointer-events: none;
 201 }
 202     </style>
 203     <script type=\"text/javascript\" src=\"~a\"></script>
 204   </head>
 205   <body>
 206     <script type=\"text/javascript\">
 207 var nodes = {},
 208     nodeArray = [],
 209     links = [];
 210 " (search-path %load-path "d3.v3.js")))
 211
 212 (define (emit-d3js-epilogue port)
 213   (format port "</script><script type=\"text/javascript\" src=\"~a\"></script></body></html>"
 214           (search-path %load-path "graph.js")))
 215
 216 (define (emit-d3js-node id label port)
 217   (format port "\
 218 nodes[\"~a\"] = {\"id\": \"~a\", \"label\": \"~a\", \"index\": nodeArray.length};
 219 nodeArray.push(nodes[\"~a\"]);~%"
 220           id id label id))
 221
 222 (define (emit-d3js-edge id1 id2 port)
 223   (format port "links.push({\"source\": \"~a\", \"target\": \"~a\"});~%"
 224           id1 id2))
 225
 226 (define %d3js-backend
 227   (graph-backend "d3js"
 228                  "Generate chord diagrams with d3js."
 229                  emit-d3js-prologue emit-d3js-epilogue
 230                  emit-d3js-node emit-d3js-edge))
 231
 232 \f
 233 ;;;
 234 ;;; Shared.
 235 ;;;
 236
 237 (define %graph-backends
 238   (list %graphviz-backend
 239         %d3js-backend))
 240
 241 (define* (export-graph sinks port
 242                        #:key
 243                        reverse-edges? node-type
 244                        (backend %graphviz-backend))
 245   "Write to PORT the representation of the DAG with the given SINKS, using the
 246 given BACKEND.  Use NODE-TYPE to traverse the DAG.  When REVERSE-EDGES? is
 247 true, draw reverse arrows."
 248   (match backend
 249     (($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge)
 250      (emit-prologue (node-type-name node-type) port)
 251
 252      (match node-type
 253        (($ <node-type> node-identifier node-label node-edges)
 254         (let loop ((nodes   sinks)
 255                    (visited (set)))
 256           (match nodes
 257             (()
 258              (with-monad %store-monad
 259                (emit-epilogue port)
 260                (store-return #t)))
 261             ((head . tail)
 262              (mlet %store-monad ((id (node-identifier head)))
 263                (if (set-contains? visited id)
 264                    (loop tail visited)
 265                    (mlet* %store-monad ((dependencies (node-edges head))
 266                                         (ids          (mapm %store-monad
 267                                                             node-identifier
 268                                                             dependencies)))
 269                      (emit-node id (node-label head) port)
 270                      (for-each (lambda (dependency dependency-id)
 271                                  (if reverse-edges?
 272                                      (emit-edge dependency-id id port)
 273                                      (emit-edge id dependency-id port)))
 274                                dependencies ids)
 275                      (loop (append dependencies tail)
 276                            (set-insert id visited)))))))))))))
 277
 278 ;;; graph.scm ends here