module-fan-in (now part of guile 1.4.x)
Thien-Thi Nguyen <[email protected]>
| Newsgroups | gmane.lisp.guile.user,gmane.lisp.guile.sources |
|---|---|
| Message-ID | <[email protected]> |
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 <[email protected]>
;;; 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
_______________________________________________
Guile-user mailing list
[email protected]
http://mail.gnu.org/mailman/listinfo/guile-user