module-fan-in (now part of guile 1.4.x)

[Thien-Thi Nguyen]

simple bfs no longer so simple.

note license change (now the same as the rest of guile 1.4.x).

thi

_____________________
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts module-fan-in)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; module-fan-in --- Recursively enumerate all upstreams of a module

;;      Copyright (C) 2003 Free Software Foundation, Inc.
;;
;; 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 2, 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 software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <address@hidden>

;;; Commentary:

;; Usage: module-fan-in [OPTIONS] MODULE
;;
;; Display all upstream modules of MODULE, one per line.
;; MODULE can be a filename or a module name (list of symbols).
;; Normally, modules are displayed starting with the "most close",
;; with the format:
;;
;;   DISTANCE MODULE-NAME FILENAME
;;
;; FILENAME can be #f for "unresolvable modules", like `(guile)'
;; or `(guile-user)', for which a filename does not make sense.
;; OPTIONS is zero or more of:
;;
;;  -r, --reverse        -- start with most remote instead of most close
;;  -d, --no-distance    -- omit display of the distance
;;  -m, --no-module-name -- omit display of the module name (list of symbols)
;;  -f, --no-filename    -- omit display of the filename
;;  -A, --no-autoloads   -- do not follow any autoload edges [default: yes]
;;  -X, --exclude MODULE -- do not follow MODULE
;;  -U, --unresolvable MODULE -- display MODULE (if found) with
;;                               filename "#f" but do not follow it
;;
;; DISTANCE is a number starting with 1 and increasing for every level of
;; indirection.  If a module has multiple distances, only the lowest one
;; (closest) is shown.  The unfollowed modules discerned by --no-autoloads
;; and --exclude are also omitted from display.  The --unresolvable and
;; --exclude options can be used multiple times.  The list of unresolvable
;; modules initially has two elements: `(guile)' and `(guile-user)'.
;;
;;
;; Usage from a Scheme Program:
;;  (use-modules (scripts module-fan-in))
;;  (module-fan-in NAMES . OPTIONS) => SEEN
;;
;; NAMES is a list whose elements are either a module-name (list of symbols)
;; or a filename (string).  SEEN is a list of module-names, each with two
;; object properties (symbols):
;;
;;   distance -- an integer
;;   filename -- a string
;;
;; The order of SEEN is farthest (from NAMES) first.  OPTIONS is zero or
;; more items, each of which is either a symbol or a list (KEY VALUE ...).
;; Recognized symbol options are:
;;
;;   no-autoloads -- corresponds to "--no-autoloads" command-line option
;;
;; Recognized key/value options are:
;;
;;   (exclude MODULE ...)      -- corresponds to "--exclude MODULE"
;;   (unresolvable MODULE ...) -- corresponds to "--unresolvable MODULE"
;;
;; Each MODULE is a list of symbols, such as: (ice-9 receive).
;; Symbol or key/value options can be given multiple times.
;;
;;
;; TODO: move module name to filename resolution proc
;;       into the morass that is the guile module system

;;; Code:

(define-module (scripts module-fan-in)
  :autoload (scripts PROGRAM) (script-MAIN)
  :use-module ((scripts frisk) :select (make-frisker
                                        mod-down-ls
                                        edge-type
                                        edge-down
                                        mod-int?))
  :use-module ((srfi srfi-1) :select (filter-map
                                      delete-duplicates
                                      lset-difference
                                      fold
                                      remove
                                      concatenate!))
  :export (module-fan-in))

(define put set-object-property!)
(define get object-property)

(define file-frisk (make-frisker))

(define (->filename name)               ; moveme
  (let ((rv (cond ((pair? name)
                   (or (%search-load-path
                        (apply string-append
                               (cons (symbol->string (car name))
                                     (map (lambda (comp)
                                            (string-append
                                             "/" (symbol->string comp)))
                                          (cdr name)))))
                       (error "could not find module:" name)))
                  ((and (string? name)
                        (file-exists? name))
                   name)
                  ((and (symbol? name)
                        (file-exists? (symbol->string name)))
                   (symbol->string name))
                  (else #f))))
    (put name 'filename rv)
    rv))

(define (frisk names)
  (file-frisk (filter-map ->filename names)))

(define (adjust-proc options)
  (let ((zonkable-autoload?
         (if (not (memq 'no-autoloads options))
             (lambda (module) #f)
             (lambda (module)
               (fold (lambda (edge zonk?)
                       (or zonk?
                           (and (eq? 'autoload (edge-type edge))
                                (mod-int? (edge-down edge)))))
                     #f
                     (mod-down-ls module)))))
        (exclude?
         (let ((all-x (concatenate!
                       (filter-map (lambda (x)
                                     (and (pair? x)
                                          (eq? 'exclude (car x))
                                          (cdr x)))
                                   options))))
           (if (null? all-x)
               (lambda (module) #f)
               (lambda (module)
                 (member module all-x))))))
    ;; retval
    (lambda (modules)
      (remove exclude? (remove zonkable-autoload? modules)))))

(define (mdiff module-set-A module-set-B)
  (lset-difference equal? module-set-A module-set-B))

(define (module-fan-in names . options)
  (let ((adjust (if (null? options) identity (adjust-proc options)))
        (all-unres (append '((guile)
                             (guile-user))
                           (concatenate!
                            (filter-map (lambda (x)
                                          (and (pair? x)
                                               (eq? 'unresolvable (car x))
                                               (cdr x)))
                                        options)))))
    (let loop ((todo names)
               (seen names)
               (distance 1))
      (if (null? todo)
          seen                          ; retval order: farthest first
          (let ((new (mdiff
                      (delete-duplicates
                       ;; simple bfs becomes (optionally) hairy here:
                       ;; - ignores unresolvable todo modules
                       ;; - filters x-down modules
                       (adjust ((frisk (mdiff todo all-unres)) 'x-down)))
                      seen)))
            (loop new
                  (append (map (lambda (x)
                                 (put x 'distance distance)
                                 x)
                               new)
                          seen)
                  (1+ distance)))))))

(define (read-from-string arg)
  (with-input-from-string arg read))

(define (module-fan-in/qop qop)
  (let ((options '()))
    (let* ((p! (lambda (x) (set! options (cons x options))))
           (k! (lambda (k v) (p! (cons k (map read-from-string
                                              (if (list? v) v (list v))))))))
      (qop 'no-autoloads (lambda ign (p! 'no-autoloads)))
      (qop 'exclude      (lambda (X) (k! 'exclude X)))
      (qop 'unresolvable (lambda (U) (k! 'unresolvable U))))
    (let ((=r (qop 'reverse))
          (=d (qop 'no-distance))
          (=m (qop 'no-module-name))
          (=f (qop 'no-filename)))
      (for-each (lambda (m)             ; module
                  (cond ((get m 'distance)
                         (or =d (display (get m 'distance)))
                         (or =m (begin (or =d (display " ")) (display m)))
                         (or =f (begin (or (and =d =m) (display " "))
                                       (display (get m 'filename))))
                         (or (and =d =m =f) (newline)))))
                ((if =r identity reverse)
                 (apply module-fan-in
                        (map read-from-string (qop '()))
                        options)))))
  #t)

(define (main . args)
  (script-MAIN args
               "module-fan-in" module-fan-in/qop
               '(usage . commentary)
               '(option-spec (reverse        (single-char #\r))
                             (no-distance    (single-char #\d))
                             (no-module-name (single-char #\m))
                             (no-filename    (single-char #\f))
                             (no-autoloads   (single-char #\A))
                             (exclude        (single-char #\X)
                                             (merge-multiple? #t)
                                             (value #t))
                             (unresolvable   (single-char #\U)
                                             (merge-multiple? #t)
                                             (value #t)))))

;;; module-fan-in ends here