Add (guix graph).
* guix/scripts/graph.scm (<node-type>, <graph-backend>, emit-prologue) (emit-epilogue, emit-node, emit-edge, %graphviz-backend, export-graph): Move to... * guix/graph.scm: ... here. New file. * guix/scripts/system.scm, tests/graph.scm: Use it. * Makefile.am (MODULES): Add it.master
Ludovic Courtès
parent
1b933e62dc
commit
8fb583714f
|
|
@ -50,6 +50,7 @@ MODULES = \
|
||||||
guix/gnu-maintenance.scm \
|
guix/gnu-maintenance.scm \
|
||||||
guix/upstream.scm \
|
guix/upstream.scm \
|
||||||
guix/licenses.scm \
|
guix/licenses.scm \
|
||||||
|
guix/graph.scm \
|
||||||
guix/build-system.scm \
|
guix/build-system.scm \
|
||||||
guix/build-system/cmake.scm \
|
guix/build-system/cmake.scm \
|
||||||
guix/build-system/emacs.scm \
|
guix/build-system/emacs.scm \
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,132 @@
|
||||||
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
|
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of GNU Guix.
|
||||||
|
;;;
|
||||||
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
(define-module (guix graph)
|
||||||
|
#:use-module (guix store)
|
||||||
|
#:use-module (guix monads)
|
||||||
|
#:use-module (guix records)
|
||||||
|
#:use-module (guix sets)
|
||||||
|
#:use-module (srfi srfi-9)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:export (node-type
|
||||||
|
node-type?
|
||||||
|
node-type-identifier
|
||||||
|
node-type-label
|
||||||
|
node-type-edges
|
||||||
|
node-type-convert
|
||||||
|
node-type-name
|
||||||
|
node-type-description
|
||||||
|
|
||||||
|
%graphviz-backend
|
||||||
|
graph-backend?
|
||||||
|
graph-backend
|
||||||
|
|
||||||
|
export-graph))
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;;;
|
||||||
|
;;; This module provides an abstract way to represent graphs and to manipulate
|
||||||
|
;;; them. It comes with several such representations for packages,
|
||||||
|
;;; derivations, and store items. It also provides a generic interface for
|
||||||
|
;;; exporting graphs in an external format, including a Graphviz
|
||||||
|
;;; implementation thereof.
|
||||||
|
;;;
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Node types.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-record-type* <node-type> node-type make-node-type
|
||||||
|
node-type?
|
||||||
|
(identifier node-type-identifier) ;node -> M identifier
|
||||||
|
(label node-type-label) ;node -> string
|
||||||
|
(edges node-type-edges) ;node -> M list of nodes
|
||||||
|
(convert node-type-convert ;package -> M list of nodes
|
||||||
|
(default (lift1 list %store-monad)))
|
||||||
|
(name node-type-name) ;string
|
||||||
|
(description node-type-description)) ;string
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Graphviz export.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-record-type <graph-backend>
|
||||||
|
(graph-backend prologue epilogue node edge)
|
||||||
|
graph-backend?
|
||||||
|
(prologue graph-backend-prologue)
|
||||||
|
(epilogue graph-backend-epilogue)
|
||||||
|
(node graph-backend-node)
|
||||||
|
(edge graph-backend-edge))
|
||||||
|
|
||||||
|
(define (emit-prologue name port)
|
||||||
|
(format port "digraph \"Guix ~a\" {\n"
|
||||||
|
name))
|
||||||
|
(define (emit-epilogue port)
|
||||||
|
(display "\n}\n" port))
|
||||||
|
(define (emit-node id label port)
|
||||||
|
(format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
|
||||||
|
id label))
|
||||||
|
(define (emit-edge id1 id2 port)
|
||||||
|
(format port " \"~a\" -> \"~a\" [color = red];~%"
|
||||||
|
id1 id2))
|
||||||
|
|
||||||
|
(define %graphviz-backend
|
||||||
|
(graph-backend emit-prologue emit-epilogue
|
||||||
|
emit-node emit-edge))
|
||||||
|
|
||||||
|
(define* (export-graph sinks port
|
||||||
|
#:key
|
||||||
|
reverse-edges? node-type
|
||||||
|
(backend %graphviz-backend))
|
||||||
|
"Write to PORT the representation of the DAG with the given SINKS, using the
|
||||||
|
given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is
|
||||||
|
true, draw reverse arrows."
|
||||||
|
(match backend
|
||||||
|
(($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
|
||||||
|
(emit-prologue (node-type-name node-type) port)
|
||||||
|
|
||||||
|
(match node-type
|
||||||
|
(($ <node-type> node-identifier node-label node-edges)
|
||||||
|
(let loop ((nodes sinks)
|
||||||
|
(visited (set)))
|
||||||
|
(match nodes
|
||||||
|
(()
|
||||||
|
(with-monad %store-monad
|
||||||
|
(emit-epilogue port)
|
||||||
|
(store-return #t)))
|
||||||
|
((head . tail)
|
||||||
|
(mlet %store-monad ((id (node-identifier head)))
|
||||||
|
(if (set-contains? visited id)
|
||||||
|
(loop tail visited)
|
||||||
|
(mlet* %store-monad ((dependencies (node-edges head))
|
||||||
|
(ids (mapm %store-monad
|
||||||
|
node-identifier
|
||||||
|
dependencies)))
|
||||||
|
(emit-node id (node-label head) port)
|
||||||
|
(for-each (lambda (dependency dependency-id)
|
||||||
|
(if reverse-edges?
|
||||||
|
(emit-edge dependency-id id port)
|
||||||
|
(emit-edge id dependency-id port)))
|
||||||
|
dependencies ids)
|
||||||
|
(loop (append dependencies tail)
|
||||||
|
(set-insert id visited)))))))))))))
|
||||||
|
|
||||||
|
;;; graph.scm ends here
|
||||||
|
|
@ -18,6 +18,7 @@
|
||||||
|
|
||||||
(define-module (guix scripts graph)
|
(define-module (guix scripts graph)
|
||||||
#:use-module (guix ui)
|
#:use-module (guix ui)
|
||||||
|
#:use-module (guix graph)
|
||||||
#:use-module (guix scripts)
|
#:use-module (guix scripts)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
|
|
@ -28,9 +29,7 @@
|
||||||
#:use-module ((guix build-system gnu) #:select (standard-packages))
|
#:use-module ((guix build-system gnu) #:select (standard-packages))
|
||||||
#:use-module (gnu packages)
|
#:use-module (gnu packages)
|
||||||
#:use-module (guix sets)
|
#:use-module (guix sets)
|
||||||
#:use-module (guix records)
|
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-37)
|
#:use-module (srfi srfi-37)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
|
@ -41,38 +40,8 @@
|
||||||
%reference-node-type
|
%reference-node-type
|
||||||
%node-types
|
%node-types
|
||||||
|
|
||||||
node-type
|
|
||||||
node-type?
|
|
||||||
node-type-identifier
|
|
||||||
node-type-label
|
|
||||||
node-type-edges
|
|
||||||
node-type-convert
|
|
||||||
node-type-name
|
|
||||||
node-type-description
|
|
||||||
|
|
||||||
%graphviz-backend
|
|
||||||
graph-backend?
|
|
||||||
graph-backend
|
|
||||||
|
|
||||||
export-graph
|
|
||||||
|
|
||||||
guix-graph))
|
guix-graph))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;; Node types.
|
|
||||||
;;;
|
|
||||||
|
|
||||||
(define-record-type* <node-type> node-type make-node-type
|
|
||||||
node-type?
|
|
||||||
(identifier node-type-identifier) ;node -> M identifier
|
|
||||||
(label node-type-label) ;node -> string
|
|
||||||
(edges node-type-edges) ;node -> M list of nodes
|
|
||||||
(convert node-type-convert ;package -> M list of nodes
|
|
||||||
(default (lift1 list %store-monad)))
|
|
||||||
(name node-type-name) ;string
|
|
||||||
(description node-type-description)) ;string
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Package DAG.
|
;;; Package DAG.
|
||||||
|
|
@ -291,73 +260,6 @@ substitutes."
|
||||||
(node-type-description type)))
|
(node-type-description type)))
|
||||||
%node-types))
|
%node-types))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;; Graphviz export.
|
|
||||||
;;;
|
|
||||||
|
|
||||||
(define-record-type <graph-backend>
|
|
||||||
(graph-backend prologue epilogue node edge)
|
|
||||||
graph-backend?
|
|
||||||
(prologue graph-backend-prologue)
|
|
||||||
(epilogue graph-backend-epilogue)
|
|
||||||
(node graph-backend-node)
|
|
||||||
(edge graph-backend-edge))
|
|
||||||
|
|
||||||
(define (emit-prologue name port)
|
|
||||||
(format port "digraph \"Guix ~a\" {\n"
|
|
||||||
name))
|
|
||||||
(define (emit-epilogue port)
|
|
||||||
(display "\n}\n" port))
|
|
||||||
(define (emit-node id label port)
|
|
||||||
(format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
|
|
||||||
id label))
|
|
||||||
(define (emit-edge id1 id2 port)
|
|
||||||
(format port " \"~a\" -> \"~a\" [color = red];~%"
|
|
||||||
id1 id2))
|
|
||||||
|
|
||||||
(define %graphviz-backend
|
|
||||||
(graph-backend emit-prologue emit-epilogue
|
|
||||||
emit-node emit-edge))
|
|
||||||
|
|
||||||
(define* (export-graph sinks port
|
|
||||||
#:key
|
|
||||||
reverse-edges?
|
|
||||||
(node-type %package-node-type)
|
|
||||||
(backend %graphviz-backend))
|
|
||||||
"Write to PORT the representation of the DAG with the given SINKS, using the
|
|
||||||
given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is
|
|
||||||
true, draw reverse arrows."
|
|
||||||
(match backend
|
|
||||||
(($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
|
|
||||||
(emit-prologue (node-type-name node-type) port)
|
|
||||||
|
|
||||||
(match node-type
|
|
||||||
(($ <node-type> node-identifier node-label node-edges)
|
|
||||||
(let loop ((nodes sinks)
|
|
||||||
(visited (set)))
|
|
||||||
(match nodes
|
|
||||||
(()
|
|
||||||
(with-monad %store-monad
|
|
||||||
(emit-epilogue port)
|
|
||||||
(store-return #t)))
|
|
||||||
((head . tail)
|
|
||||||
(mlet %store-monad ((id (node-identifier head)))
|
|
||||||
(if (set-contains? visited id)
|
|
||||||
(loop tail visited)
|
|
||||||
(mlet* %store-monad ((dependencies (node-edges head))
|
|
||||||
(ids (mapm %store-monad
|
|
||||||
node-identifier
|
|
||||||
dependencies)))
|
|
||||||
(emit-node id (node-label head) port)
|
|
||||||
(for-each (lambda (dependency dependency-id)
|
|
||||||
(if reverse-edges?
|
|
||||||
(emit-edge dependency-id id port)
|
|
||||||
(emit-edge id dependency-id port)))
|
|
||||||
dependencies ids)
|
|
||||||
(loop (append dependencies tail)
|
|
||||||
(set-insert id visited)))))))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Command-line options.
|
;;; Command-line options.
|
||||||
|
|
|
||||||
|
|
@ -29,6 +29,7 @@
|
||||||
#:use-module (guix profiles)
|
#:use-module (guix profiles)
|
||||||
#:use-module (guix scripts)
|
#:use-module (guix scripts)
|
||||||
#:use-module (guix scripts build)
|
#:use-module (guix scripts build)
|
||||||
|
#:use-module (guix graph)
|
||||||
#:use-module (guix scripts graph)
|
#:use-module (guix scripts graph)
|
||||||
#:use-module (guix build utils)
|
#:use-module (guix build utils)
|
||||||
#:use-module (gnu build install)
|
#:use-module (gnu build install)
|
||||||
|
|
|
||||||
|
|
@ -18,6 +18,7 @@
|
||||||
|
|
||||||
(define-module (test-graph)
|
(define-module (test-graph)
|
||||||
#:use-module (guix tests)
|
#:use-module (guix tests)
|
||||||
|
#:use-module (guix graph)
|
||||||
#:use-module (guix scripts graph)
|
#:use-module (guix scripts graph)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module (guix derivations)
|
#:use-module (guix derivations)
|
||||||
|
|
|
||||||
Reference in New Issue