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             node-transitive-edges
  41
  42             %graphviz-backend
  43             graph-backend?
  44             graph-backend
  45
  46             export-graph))
  47
  48 ;;; Commentary:
  49 ;;;
  50 ;;; This module provides an abstract way to represent graphs and to manipulate
  51 ;;; them.  It comes with several such representations for packages,
  52 ;;; derivations, and store items.  It also provides a generic interface for
  53 ;;; exporting graphs in an external format, including a Graphviz
  54 ;;; implementation thereof.
  55 ;;;
  56 ;;; Code:
  57
  58 \f
  59 ;;;
  60 ;;; Node types.
  61 ;;;
  62
  63 (define-record-type* <node-type> node-type make-node-type
  64   node-type?
  65   (identifier  node-type-identifier)              ;node -> M identifier
  66   (label       node-type-label)                   ;node -> string
  67   (edges       node-type-edges)                   ;node -> M list of nodes
  68   (convert     node-type-convert                  ;any -> M list of nodes
  69                (default (lift1 list %store-monad)))
  70   (name        node-type-name)                    ;string
  71   (description node-type-description))            ;string
  72
  73 (define (%node-edges type nodes cons-edge)
  74   (with-monad %store-monad
  75     (match type
  76       (($ <node-type> identifier label node-edges)
  77        (define (add-edge node edges)
  78          (>>= (node-edges node)
  79               (lambda (nodes)
  80                 (return (fold (cut cons-edge node <> <>)
  81                               edges nodes)))))
  82
  83        (mlet %store-monad ((edges (foldm %store-monad
  84                                          add-edge vlist-null nodes)))
  85          (return (lambda (node)
  86                    (reverse (vhash-foldq* cons '() node edges)))))))))
  87
  88 (define (node-edges type nodes)
  89   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
  90 returns its edges.  NODES is taken to be the sinks of the global graph."
  91   (%node-edges type nodes
  92                (lambda (source target edges)
  93                  (vhash-consq source target edges))))
  94
  95 (define (node-back-edges type nodes)
  96   "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
  97 returns its back edges.  NODES is taken to be the sinks of the global graph."
  98   (%node-edges type nodes
  99                (lambda (source target edges)
 100                  (vhash-consq target source edges))))
 101
 102 (define (node-transitive-edges nodes node-edges)
 103   "Return the list of nodes directly or indirectly connected to NODES
 104 according to the NODE-EDGES procedure.  NODE-EDGES must be a one-argument
 105 procedure that, given a node, returns its list of direct dependents; it is
 106 typically returned by 'node-edges' or 'node-back-edges'."
 107   (let loop ((nodes   (append-map node-edges nodes))
 108              (result  '())
 109              (visited (setq)))
 110     (match nodes
 111       (()
 112        result)
 113       ((head . tail)
 114        (if (set-contains? visited head)
 115            (loop tail result visited)
 116            (let ((edges (node-edges head)))
 117              (loop (append edges tail)
 118                    (cons head result)
 119                    (set-insert head visited))))))))
 120
 121 \f
 122 ;;;
 123 ;;; Graphviz export.
 124 ;;;
 125
 126 (define-record-type <graph-backend>
 127   (graph-backend prologue epilogue node edge)
 128   graph-backend?
 129   (prologue graph-backend-prologue)
 130   (epilogue graph-backend-epilogue)
 131   (node     graph-backend-node)
 132   (edge     graph-backend-edge))
 133
 134 (define %colors
 135   ;; See colortbl.h in Graphviz.
 136   #("red" "magenta" "blue" "cyan3" "darkseagreen"
 137     "peachpuff4" "darkviolet" "dimgrey" "darkgoldenrod"))
 138
 139 (define (pop-color hint)
 140   "Return a Graphviz color based on HINT, an arbitrary object."
 141   (let ((index (hash hint (vector-length %colors))))
 142     (vector-ref %colors index)))
 143
 144 (define (emit-prologue name port)
 145   (format port "digraph \"Guix ~a\" {\n"
 146           name))
 147 (define (emit-epilogue port)
 148   (display "\n}\n" port))
 149 (define (emit-node id label port)
 150   (format port "  \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
 151           id label))
 152 (define (emit-edge id1 id2 port)
 153   (format port "  \"~a\" -> \"~a\" [color = ~a];~%"
 154           id1 id2 (pop-color id1)))
 155
 156 (define %graphviz-backend
 157   (graph-backend emit-prologue emit-epilogue
 158                  emit-node emit-edge))
 159
 160 (define* (export-graph sinks port
 161                        #:key
 162                        reverse-edges? node-type
 163                        (backend %graphviz-backend))
 164   "Write to PORT the representation of the DAG with the given SINKS, using the
 165 given BACKEND.  Use NODE-TYPE to traverse the DAG.  When REVERSE-EDGES? is
 166 true, draw reverse arrows."
 167   (match backend
 168     (($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
 169      (emit-prologue (node-type-name node-type) port)
 170
 171      (match node-type
 172        (($ <node-type> node-identifier node-label node-edges)
 173         (let loop ((nodes   sinks)
 174                    (visited (set)))
 175           (match nodes
 176             (()
 177              (with-monad %store-monad
 178                (emit-epilogue port)
 179                (store-return #t)))
 180             ((head . tail)
 181              (mlet %store-monad ((id (node-identifier head)))
 182                (if (set-contains? visited id)
 183                    (loop tail visited)
 184                    (mlet* %store-monad ((dependencies (node-edges head))
 185                                         (ids          (mapm %store-monad
 186                                                             node-identifier
 187                                                             dependencies)))
 188                      (emit-node id (node-label head) port)
 189                      (for-each (lambda (dependency dependency-id)
 190                                  (if reverse-edges?
 191                                      (emit-edge dependency-id id port)
 192                                      (emit-edge id dependency-id port)))
 193                                dependencies ids)
 194                      (loop (append dependencies tail)
 195                            (set-insert id visited)))))))))))))
 196
 197 ;;; graph.scm ends here