From: mhw@netris.org
To: 18247@debbugs.gnu.org
Subject: bug#18247: Cyclic dependencies in (gnu package *) modules
Date: Mon, 11 Aug 2014 16:49:36 -0400 [thread overview]
Message-ID: <87a97abvkv.fsf@netris.org> (raw)
In-Reply-To: <87egwmbxln.fsf@netris.org> (mhw@netris.org's message of "Mon, 11 Aug 2014 16:05:56 -0400")
[-- Attachment #1: Type: text/plain, Size: 170 bytes --]
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
[-- Attachment #2: Script to find cyclic dependencies in guix package modules --]
[-- Type: text/plain, Size: 5261 bytes --]
(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))
next prev parent reply other threads:[~2014-08-11 20:50 UTC|newest]
Thread overview: 14+ messages / expand[flat|nested] mbox.gz Atom feed top
2014-08-11 20:05 bug#18247: Cyclic dependencies in (gnu package *) modules mhw
2014-08-11 20:49 ` mhw [this message]
2014-08-11 21:07 ` Ludovic Courtès
2014-08-11 23:59 ` Mark H Weaver
2014-08-12 3:28 ` mhw
2014-08-12 7:31 ` mhw
2014-08-12 13:54 ` Ludovic Courtès
2014-08-12 20:53 ` Eric Bavier
2014-08-13 18:55 ` Mark H Weaver
2014-08-13 22:09 ` Ludovic Courtès
2014-08-16 6:00 ` Eric Bavier
2014-08-16 9:11 ` Ludovic Courtès
2014-08-28 9:41 ` Ludovic Courtès
2014-08-12 11:05 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87a97abvkv.fsf@netris.org \
--to=mhw@netris.org \
--cc=18247@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.