guix/graph.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix graph)
  20   #:use-module (guix store)
  21   #:use-module (guix monads)
  22   #:use-module (guix records)
  23   #:use-module (guix sets)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-9)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 vlist)
  29   #:export (node-type
  30             node-type?
  31             node-type-identifier
  32             node-type-label
  33             node-type-edges
  34             node-type-convert
  35             node-type-name
  36             node-type-description
  37
  38             node-edges
  39             node-back-edges
  40             traverse/depth-first
  41             node-transitive-edges
  42             node-reachable-count
  43
  44             %graphviz-backend
  45             graph-backend?
  46             graph-backend
  47
  48             export-graph))
  49
  50 ;;; Commentary:
  51 ;;;
  52 ;;; This module provides an abstract way to represent graphs and to manipulate
  53 ;;; them.  It comes with several such representations for packages,
  54 ;;; derivations, and store items.  It also provides a generic interface for
  55 ;;; exporting graphs in an external format, including a Graphviz
  56 ;;; implementation thereof.
  57 ;;;
  58 ;;; Code:
  59
  60 \f
  61 ;;;
  62 ;;; Node types.
  63 ;;;
  64
  65 (define-record-type* <node-type> node-type make-node-type
  66   node-type?
  67   (identifier  node-type-identifier)              ;node -> M identifier
  68   (label       node-type-label)                   ;node -> string
  69   (edges       node-type-edges)                   ;node -> M list of nodes
  70   (convert     node-type-convert                  ;any -> M list of nodes
  71                (default (lift1 list %store-monad)))
  72   (name        node-type-name)                    ;string
  73   (description node-type-description))            ;string
  74
  75 (define (%node-edges type nodes cons-edge)
  76   (with-monad %store-monad
  77     (match type
  78       (($ <node-type> identifier label node-edges)
  79        (define (add-edge node edges)
  80          (>>= (node-edges node)
  81               (lambda (nodes)
  82                 (return (fold (cut cons-edge node <> <>)
  83                               edges nodes)))))
  84
  85        (mlet %store-monad ((edges (foldm %store-monad
  86                                          add-edge vlist-null nodes)))
  87          (return (lambda (node)
  88                    (reverse (vhash-foldq* cons '() node edges)))))))))
  89
  90 (define (node-edges type nodes)
  91   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
  92 returns its edges.  NODES is taken to be the sinks of the global graph."
  93   (%node-edges type nodes
  94                (lambda (source target edges)
  95                  (vhash-consq source target edges))))
  96
  97 (define (node-back-edges type nodes)
  98   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
  99 returns its back 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 target source edges))))
 103
 104 (define (traverse/depth-first proc seed nodes node-edges)
 105   "Do a depth-first traversal of NODES along NODE-EDGES, calling PROC with
 106 each node and the current result, and visiting each reachable node exactly
 107 once.  NODES must be a list of nodes, and NODE-EDGES must be a one-argument
 108 procedure as returned by 'node-edges' or 'node-back-edges'."
 109   (let loop ((nodes   (append-map node-edges nodes))
 110              (result  seed)
 111              (visited (setq)))
 112     (match nodes
 113       (()
 114        result)
 115       ((head . tail)
 116        (if (set-contains? visited head)
 117            (loop tail result visited)
 118            (let ((edges (node-edges head)))
 119              (loop (append edges tail)
 120                    (proc head result)
 121                    (set-insert head visited))))))))
 122
 123 (define (node-transitive-edges nodes node-edges)
 124   "Return the list of nodes directly or indirectly connected to NODES
 125 according to the NODE-EDGES procedure.  NODE-EDGES must be a one-argument
 126 procedure that, given a node, returns its list of direct dependents; it is
 127 typically returned by 'node-edges' or 'node-back-edges'."
 128   (traverse/depth-first cons '() nodes node-edges))
 129
 130 (define (node-reachable-count nodes node-edges)
 131   "Return the number of nodes reachable from NODES along NODE-EDGES."
 132   (traverse/depth-first (lambda (_ count)
 133                           (+ 1 count))
 134                         0
 135                         nodes node-edges))
 136
 137 \f
 138 ;;;
 139 ;;; Graphviz export.
 140 ;;;
 141
 142 (define-record-type <graph-backend>
 143   (graph-backend prologue epilogue node edge)
 144   graph-backend?
 145   (prologue graph-backend-prologue)
 146   (epilogue graph-backend-epilogue)
 147   (node     graph-backend-node)
 148   (edge     graph-backend-edge))
 149
 150 (define %colors
 151   ;; See colortbl.h in Graphviz.
 152   #("red" "magenta" "blue" "cyan3" "darkseagreen"
 153     "peachpuff4" "darkviolet" "dimgrey" "darkgoldenrod"))
 154
 155 (define (pop-color hint)
 156   "Return a Graphviz color based on HINT, an arbitrary object."
 157   (let ((index (hash hint (vector-length %colors))))
 158     (vector-ref %colors index)))
 159
 160 (define (emit-prologue name port)
 161   (format port "digraph \"Guix ~a\" {\n"
 162           name))
 163 (define (emit-epilogue port)
 164   (display "\n}\n" port))
 165 (define (emit-node id label port)
 166   (format port "  \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
 167           id label))
 168 (define (emit-edge id1 id2 port)
 169   (format port "  \"~a\" -> \"~a\" [color = ~a];~%"
 170           id1 id2 (pop-color id1)))
 171
 172 (define %graphviz-backend
 173   (graph-backend emit-prologue emit-epilogue
 174                  emit-node emit-edge))
 175
 176 (define* (export-graph sinks port
 177                        #:key
 178                        reverse-edges? node-type
 179                        (backend %graphviz-backend))
 180   "Write to PORT the representation of the DAG with the given SINKS, using the
 181 given BACKEND.  Use NODE-TYPE to traverse the DAG.  When REVERSE-EDGES? is
 182 true, draw reverse arrows."
 183   (match backend
 184     (($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
 185      (emit-prologue (node-type-name node-type) port)
 186
 187      (match node-type
 188        (($ <node-type> node-identifier node-label node-edges)
 189         (let loop ((nodes   sinks)
 190                    (visited (set)))
 191           (match nodes
 192             (()
 193              (with-monad %store-monad
 194                (emit-epilogue port)
 195                (store-return #t)))
 196             ((head . tail)
 197              (mlet %store-monad ((id (node-identifier head)))
 198                (if (set-contains? visited id)
 199                    (loop tail visited)
 200                    (mlet* %store-monad ((dependencies (node-edges head))
 201                                         (ids          (mapm %store-monad
 202                                                             node-identifier
 203                                                             dependencies)))
 204                      (emit-node id (node-label head) port)
 205                      (for-each (lambda (dependency dependency-id)
 206                                  (if reverse-edges?
 207                                      (emit-edge dependency-id id port)
 208                                      (emit-edge id dependency-id port)))
 209                                dependencies ids)
 210                      (loop (append dependencies tail)
 211                            (set-insert id visited)))))))))))))
 212
 213 ;;; graph.scm ends here