[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/03: Add (guix graph).
|
From: |
Ludovic Courtès |
|
Subject: |
01/03: Add (guix graph). |
|
Date: |
Sat, 21 Nov 2015 15:28:21 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit 8fb583714f78d1b283523ef7edbb6e098946182f
Author: Ludovic Courtès <address@hidden>
Date: Sat Nov 21 13:12:02 2015 +0100
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.
---
Makefile.am | 1 +
guix/graph.scm | 132 +++++++++++++++++++++++++++++++++++++++++++++++
guix/scripts/graph.scm | 100 +-----------------------------------
guix/scripts/system.scm | 1 +
tests/graph.scm | 1 +
5 files changed, 136 insertions(+), 99 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 67d483b..43be2ec 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -50,6 +50,7 @@ MODULES = \
guix/gnu-maintenance.scm \
guix/upstream.scm \
guix/licenses.scm \
+ guix/graph.scm \
guix/build-system.scm \
guix/build-system/cmake.scm \
guix/build-system/emacs.scm \
diff --git a/guix/graph.scm b/guix/graph.scm
new file mode 100644
index 0000000..05325ba
--- /dev/null
+++ b/guix/graph.scm
@@ -0,0 +1,132 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <address@hidden>
+;;;
+;;; 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
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 734a477..f607ebe 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -18,6 +18,7 @@
(define-module (guix scripts graph)
#:use-module (guix ui)
+ #:use-module (guix graph)
#:use-module (guix scripts)
#:use-module (guix utils)
#:use-module (guix packages)
@@ -28,9 +29,7 @@
#:use-module ((guix build-system gnu) #:select (standard-packages))
#:use-module (gnu packages)
#:use-module (guix sets)
- #:use-module (guix records)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
@@ -41,40 +40,10 @@
%reference-node-type
%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))
;;;
-;;; 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.
;;;
@@ -293,73 +262,6 @@ substitutes."
;;;
-;;; 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.
;;;
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 0d54d45..1407dc7 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -29,6 +29,7 @@
#:use-module (guix profiles)
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (guix graph)
#:use-module (guix scripts graph)
#:use-module (guix build utils)
#:use-module (gnu build install)
diff --git a/tests/graph.scm b/tests/graph.scm
index f454b06..ed5849f 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -18,6 +18,7 @@
(define-module (test-graph)
#:use-module (guix tests)
+ #:use-module (guix graph)
#:use-module (guix scripts graph)
#:use-module (guix packages)
#:use-module (guix derivations)