bug#51021: detect loops in module/package graph

[Mark H Weaver]

Earlier, I wrote
> I've attached a script that I hacked up in 2014 to analyze the Guix
> package module dependency graph.

Here's the script:

;;; cycle-viewer.scm: a Guix package module dependency graph analyzer
;;; Copyright (C) 2014  Mark H Weaver <mhw@netris.org>
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(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 name) . _) 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 ('gnu 'packages module) . rest)
        (let loop ((rest rest)
                   (deps '()))
          (match rest
            (() deps)
            ((#:use-module ('gnu 'packages name) . rest)
             (loop rest `((,module . ,name) . ,deps)))
            ((#:use-module (('gnu 'packages name) . _) . rest)
             (loop rest `((,module . ,name) . ,deps)))
            ((#:use-module _ . rest)
             (loop rest deps))
            ((#:export _ . rest)
             (loop rest deps))
            ((#:autoload _ _ . rest)
             (loop rest deps)))))
       (('define-module module-name . _) '())))
   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 (null? non-trivial-sccs)
  (display "Found the following non-trivial strongly-connected components:")
  (newline)
  (for-each (lambda (scc)
              (pretty-print scc)
              (newline))
            non-trivial-sccs))

(define (edges-within vs)
  (filter (match-lambda
            ((a . b) (and (member a vs) (member b vs))))
          dependencies))

(define (edges-involving vs)
  (filter (match-lambda
            ((a . b) (or (member a vs) (member b vs))))
          dependencies))

(define (edges-from vs)
  (filter (match-lambda
            ((a . b) (member a vs)))
          dependencies))

(define (edges-to vs)
  (filter (match-lambda
            ((a . b) (member b vs)))
          dependencies))

(define (module-label module)
  (symbol->string module))

(define* (write-edges-dot edges #:optional (port (current-output-port)))
  (display "digraph {\n" port)
  (for-each (match-lambda
              ((a . b) (format port "  ~S -> ~S;\n"
                               (module-label a)
                               (module-label b))))
            edges)
  (display "}\n" port))

(define* (write-scc-dot scc #:optional (port (current-output-port)))
  (write-edges-dot (edges-within scc) port))

-- 
Disinformation flourishes because many people care deeply about injustice
but very few check the facts.  Ask me about <https://stallmansupport.org>.