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
parent
8fb583714f
commit
923d846c4d
|
@ -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.
|
||||
|
|
|
@ -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")
|
||||
|
||||
|
||||
|
|
Reference in New Issue