I hacked up the following Guile script to automatically find cyclic
dependencies in (gnu packages *). It must be run from Guix's top-level
source directory.
Mark
(use-modules (srfi srfi-1)
(srfi srfi-26)
(ice-9 match)
(ice-9 ftw)
(ice-9 pretty-print))
;;;
;;; Tarjan's strongly connected components algorithm
;;;
;;; Robert Tarjan, Depth-first search and linear graph algorithms.
;;; SIAM Journal on Computing, 1(2):146-160, 1972.
;;;
;;;
;;; vertices is the list of vertices, which may be any objects that
;;; can be distinguished using 'equal?'.
;;;
;;; edges is the list of edges, where each edge is a pair (w . v)
;;; representing the directed edge w => v, for vertices w and v.
;;;
;;; The return value is a list of the strongly-connected components,
;;; where each strongly-connected component (SCC) is represented as a
;;; list of the vertices it contains. The returned SCCs are sorted in
;;; topological order.
;;;
(define (strongly-connected-components vertices edges)
(define size (length vertices))
(define vs (iota size))
(define lookup
(let ((t (make-hash-table size)))
(for-each (cut hash-set! t <> <>) vertices vs)
(cut hash-ref t <>)))
(define name
(let ((t (make-vector size #f)))
(for-each (cut vector-set! t <> <>) vs vertices)
(cut vector-ref t <>)))
(define (vector-update! v i f)
(vector-set! v i (f (vector-ref v i))))
(define (compose f g) (lambda (x) (f (g x))))
(define successors
(let ((t (make-vector size '())))
(for-each (lambda (v w) (vector-update! t v (cut cons w <>)))
(map (compose lookup car) edges)
(map (compose lookup cdr) edges))
(cut vector-ref t <>)))
(define new-index
(let ((i -1))
(lambda ()
(set! i (+ i 1))
i)))
(define index-table (make-vector size #f))
(define index (cut vector-ref index-table <>))
(define set-index! (cut vector-set! index-table <> <>))
(define lowlink-table (make-vector size size))
(define lowlink (cut vector-ref lowlink-table <>))
(define (update-lowlink! v x)
(if v (vector-update! lowlink-table v (cut min x <>))))
(define done-table (make-bitvector size #f))
(define done? (cut bitvector-ref done-table <>))
(define done! (cut bitvector-set! done-table <> #t))
(define results '())
(define pending '())
(define (finalize! v)
(let loop ((names '()) (p pending))
(done! (car p))
(cond ((eqv? v (car p))
(set! pending (cdr p))
(set! results (cons (cons (name v) names)
results)))
(else (loop (cons (name (car p))
names)
(cdr p))))))
(let loop ((v #f) (ws vs) (stack '()))
(cond ((pair? ws)
(let ((w (car ws)))
(cond ((index w) => (lambda (wi)
(if (not (done? w))
(update-lowlink! v wi))
(loop v (cdr ws) stack)))
(else (let ((wi (new-index)))
(set-index! w wi)
(update-lowlink! w wi)
(set! pending (cons w pending))
(loop w (successors w)
(cons (cons v (cdr ws))
stack)))))))
((pair? stack)
(if (and v (= (index v) (lowlink v)))
(finalize! v))
(update-lowlink! (caar stack) (lowlink v))
(loop (caar stack) (cdar stack) (cdr stack)))
(else results))))
(chdir "gnu/packages")
(define files (scandir "." (cut string-suffix? ".scm" <>)))
(define headers (map (cut call-with-input-file <> read)
files))
(define modules
(filter-map
(lambda (header)
(match header
(('define-module ('gnu 'packages name0 name* ...) . _)
`(gnu packages ,name0 ,@name*))
(('define-module module-name . _)
(format (current-warning-port)
"Warning: found unexpected module name ~S in
gnu/packages/*.scm~%"
module-name)
#f)))
headers))
(define dependencies
(append-map
(lambda (header)
(match header
(('define-module module . rest)
(let loop ((rest rest)
(deps '()))
(match rest
(() deps)
((#:use-module ('gnu 'packages name0 name* ...) . rest)
(loop rest `((,module . (gnu packages ,name0 ,@name*)) . ,deps)))
((#:use-module (('gnu 'packagess name0 name* ...) . _) . rest)
(loop rest `((,module . (gnu packages ,name0 ,@name*)) . ,deps)))
((#:use-module _ . rest)
(loop rest deps))
((#:export _ . rest)
(loop rest deps))
((#:autoload _ _ . rest)
(loop rest deps)))))))
headers))
(define sccs (strongly-connected-components modules dependencies))
(define (non-trivial? scc)
(not (= 1 (length scc))))
(define non-trivial-sccs (filter non-trivial? sccs))
(unless (zero? (length non-trivial-sccs))
(display "Found the following non-trivial strongly-connected components:")
(newline)
(for-each (lambda (scc)
(pretty-print scc)
(newline))
non-trivial-sccs))
