me
/
guix
Archived
1
0
Fork 0

graph: Add procedures to query a node's edges.

* guix/graph.scm (%node-edges, node-edges, node-back-edges)
(node-transitive-edges): New procedures.
* tests/graph.scm ("node-edges")
("node-transitive-edges + node-back-edges"): New tests.
master
Ludovic Courtès 2015-11-21 14:48:34 +01:00
parent 8fb583714f
commit 923d846c4d
2 changed files with 92 additions and 1 deletions

View File

@ -21,8 +21,11 @@
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix sets)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:export (node-type
node-type?
node-type-identifier
@ -32,6 +35,10 @@
node-type-name
node-type-description
node-edges
node-back-edges
node-transitive-edges
%graphviz-backend
graph-backend?
graph-backend
@ -63,6 +70,54 @@
(name node-type-name) ;string
(description node-type-description)) ;string
(define (%node-edges type nodes cons-edge)
(with-monad %store-monad
(match type
(($ <node-type> identifier label node-edges)
(define (add-edge node edges)
(>>= (node-edges node)
(lambda (nodes)
(return (fold (cut cons-edge node <> <>)
edges nodes)))))
(mlet %store-monad ((edges (foldm %store-monad
add-edge vlist-null nodes)))
(return (lambda (node)
(reverse (vhash-foldq* cons '() node edges)))))))))
(define (node-edges type nodes)
"Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
returns its edges. NODES is taken to be the sinks of the global graph."
(%node-edges type nodes
(lambda (source target edges)
(vhash-consq source target edges))))
(define (node-back-edges type nodes)
"Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
returns its back edges. NODES is taken to be the sinks of the global graph."
(%node-edges type nodes
(lambda (source target edges)
(vhash-consq target source edges))))
(define (node-transitive-edges nodes node-edges)
"Return the list of nodes directly or indirectly connected to NODES
according to the NODE-EDGES procedure. NODE-EDGES must be a one-argument
procedure that, given a node, returns its list of direct dependents; it is
typically returned by 'node-edges' or 'node-back-edges'."
(let loop ((nodes (append-map node-edges nodes))
(result '())
(visited (setq)))
(match nodes
(()
result)
((head . tail)
(if (set-contains? visited head)
(loop tail result visited)
(let ((edges (node-edges head)))
(loop (append edges tail)
(cons head result)
(set-insert head visited))))))))
;;;
;;; Graphviz export.

View File

@ -25,8 +25,12 @@
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix build-system gnu)
#:use-module (guix build-system trivial)
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (gnu packages)
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
@ -111,7 +115,7 @@ edges."
".drv")))
implicit)))))))
(test-assert "bag DAG"
(test-assert "bag DAG" ;a big town in Iraq
(let-values (((backend nodes+edges) (make-recording-backend)))
(let ((p (dummy-package "p")))
(run-with-store %store
@ -188,6 +192,38 @@ edges."
(list out txt))
(equal? edges `((,out ,txt)))))))))))
(test-assert "node-edges"
(run-with-store %store
(let ((packages (fold-packages cons '())))
(mlet %store-monad ((edges (node-edges %package-node-type packages)))
(return (and (null? (edges grep))
(lset= eq?
(edges guile-2.0)
(match (package-direct-inputs guile-2.0)
(((labels packages _ ...) ...)
packages)))))))))
(test-assert "node-transitive-edges + node-back-edges"
(run-with-store %store
(let ((packages (fold-packages cons '()))
(bootstrap? (lambda (package)
(string-contains
(location-file (package-location package))
"bootstrap.scm")))
(trivial? (lambda (package)
(eq? (package-build-system package)
trivial-build-system))))
(mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
(let* ((glibc (canonical-package glibc))
(dependents (node-transitive-edges (list glibc) edges))
(diff (lset-difference eq? packages dependents)))
;; All the packages depend on libc, except bootstrap packages and
;; some that use TRIVIAL-BUILD-SYSTEM.
(return (null? (remove (lambda (package)
(or (trivial? package)
(bootstrap? package)))
diff))))))))
(test-end "graph")