executable module: module-fan-in.scm

[Thien-Thi Nguyen]

this is used by scm2bin.scm 1.1 (to be posted shortly), and will
probably make it into guile 1.4.2.  (now i challenge someone to write
the analogous module-fan-out program. ;-)

btw, finally got the hdd in storage since february into an accomodating
drive bay, so www.glug.org will be resuming updates in a few days.

patches welcome, of course.

thi


_______________________________________________________
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(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 Thien-Thi Nguyen
;;
;; 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

;;; 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 "pre-loaded 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
;;
;; 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.
;;
;;
;; Usage from a Scheme Program:
;;  (use-modules (module-fan-in))
;;  (module-fan-in NAMES) => 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.
;;
;;
;; TODO: move `->filename' to (scripts frisk)
;;       handle edge types in configurable ways (e.g., omit "autoload")

;;; Code:

(define-module (module-fan-in)
  :use-module ((scripts PROGRAM) :select (script-MAIN))
  :use-module ((scripts frisk) :select (make-frisker))
  :use-module ((srfi srfi-1) :select (filter-map
                                      delete-duplicates
                                      lset-difference))
  :export (module-fan-in))

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

(define file-frisk (make-frisker))

(define (->filename name)
  (let ((rv (cond ((pair? name)
                   (%search-load-path
                    (apply string-append
                           (cons (symbol->string (car name))
                                 (map (lambda (comp)
                                        (string-append
                                         "/" (symbol->string comp)))
                                      (cdr 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 (module-fan-in names)           ; garden variety bfs
  (let loop ((todo names)
             (seen names)
             (distance 1))
    (if (null? todo)
        seen                            ; retval order: farthest first
        (let ((new (lset-difference equal?
                                    (delete-duplicates
                                     ((frisk todo)
                                      ;; x-down gives all possible edge types
                                      ;; but probably we want to be a bit more
                                      ;; discerning (e.g., omit "autoload"),
                                      ;; or at least make this configurable
                                      'x-down))
                                    seen)))
          (loop new
                (append (map (lambda (x)
                               (put x 'distance distance)
                               x)
                             new)
                        seen)
                (1+ distance))))))

(define (module-fan-in/qop qop)
  (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)
               (module-fan-in (map (lambda (arg)
                                     (with-input-from-string arg read))
                                   (qop '()))))))
  #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)))))

;;; module-fan-in ends here