bug#18247: Cyclic dependencies in (gnu package *) modules

[mhw]

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))