--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; frisk --- Grok the module interfaces of a body of files
+
+;; Copyright (C) 2002, 2006 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., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: frisk [options] file ...
+;;
+;; Analyze FILE... module interfaces in aggregate (as a "body"),
+;; and display a summary. Modules that are `define-module'd are
+;; considered "internal" (and those not, "external"). When module X
+;; uses module Y, X is said to be "(a) downstream of" Y, and Y is
+;; "(an) upstream of" X.
+;;
+;; Normally, the summary displays external modules and their internal
+;; downstreams, as this is the usual question asked by a body. There
+;; are several options that modify this output.
+;;
+;; -u, --upstream show upstream edges
+;; -d, --downstream show downstream edges (default)
+;; -i, --internal show internal modules
+;; -x, --external show external modules (default)
+;;
+;; If given both `upstream' and `downstream' options ("frisk -ud"), the
+;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is
+;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE
+;; MODULE-NAME ...).
+;;
+;; In all other cases, the "C MODULE" occupies its own line, and
+;; subsequent lines list the up- or downstream edges, respectively,
+;; indented by some non-zero amount of whitespace.
+;;
+;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a
+;; file that do not follow a `define-module' result an edge where the
+;; downstream is the "default module", normally `(guile-user)'. This
+;; can be set to another value by using:
+;;
+;; -m, --default-module MOD set MOD as the default module
+
+;; Usage from a Scheme Program: (use-modules (scripts frisk))
+;;
+;; Module export list:
+;; (frisk . args)
+;; (make-frisker . options) => (lambda (files) ...) [see below]
+;; (mod-up-ls module) => upstream edges
+;; (mod-down-ls module) => downstream edges
+;; (mod-int? module) => is the module internal?
+;; (edge-type edge) => symbol: {regular,autoload,computed}
+;; (edge-up edge) => upstream module
+;; (edge-down edge) => downstream module
+;;
+;; OPTIONS is an alist. Recognized keys are:
+;; default-module
+;;
+;; `make-frisker' returns a procedure that takes a list of files, the
+;; FRISKER. FRISKER returns a closure, REPORT, that takes one of the
+;; keys:
+;; modules -- entire list of modules
+;; internal -- list of internal modules
+;; external -- list of external modules
+;; i-up -- list of modules upstream of internal modules
+;; x-up -- list of modules upstream of external modules
+;; i-down -- list of modules downstream of internal modules
+;; x-down -- list of modules downstream of external modules
+;; edges -- list of edges
+;; Note that `x-up' should always be null, since by (lack of!)
+;; definition, we only know external modules by reference.
+;;
+;; The module and edge objects managed by REPORT can be examined in
+;; detail by using the other (self-explanatory) procedures. Be careful
+;; not to confuse a freshly consed list of symbols, like `(a b c)' with
+;; the module `(a b c)'. If you want to find the module by that name,
+;; try: (cond ((member '(a b c) (REPORT 'modules)) => car)).
+
+;; TODO: Make "frisk -ud" output less ugly.
+;; Consider default module as internal; add option to invert.
+;; Support `edge-misc' data.
+
+;;; Code:
+
+(define-module (scripts frisk)
+ :autoload (ice-9 getopt-long) (getopt-long)
+ :use-module ((srfi srfi-1) :select (filter remove))
+ :export (frisk
+ make-frisker
+ mod-up-ls mod-down-ls mod-int?
+ edge-type edge-up edge-down))
+
+(define *default-module* '(guile-user))
+
+(define (grok-proc default-module note-use!)
+ (lambda (filename)
+ (let* ((p (open-file filename "r"))
+ (next (lambda () (read p)))
+ (ferret (lambda (use) ;;; handle "((foo bar) :select ...)"
+ (let ((maybe (car use)))
+ (if (list? maybe)
+ maybe
+ use))))
+ (curmod #f))
+ (let loop ((form (next)))
+ (cond ((eof-object? form))
+ ((not (list? form)) (loop (next)))
+ (else (case (car form)
+ ((define-module)
+ (let ((module (cadr form)))
+ (set! curmod module)
+ (note-use! 'def module #f)
+ (let loop ((ls form))
+ (or (null? ls)
+ (case (car ls)
+ ((:use-module)
+ (note-use! 'regular module (ferret (cadr ls)))
+ (loop (cddr ls)))
+ ((:autoload)
+ (note-use! 'autoload module (cadr ls))
+ (loop (cdddr ls)))
+ (else (loop (cdr ls))))))))
+ ((use-modules)
+ (for-each (lambda (use)
+ (note-use! 'regular
+ (or curmod default-module)
+ (ferret use)))
+ (cdr form)))
+ ((load primitive-load)
+ (note-use! 'computed
+ (or curmod default-module)
+ (let ((file (cadr form)))
+ (if (string? file)
+ file
+ (format #f "[computed in ~A]"
+ filename))))))
+ (loop (next))))))))
+
+(define up-ls (make-object-property)) ; list
+(define dn-ls (make-object-property)) ; list
+(define int? (make-object-property)) ; defined via `define-module'
+
+(define mod-up-ls up-ls)
+(define mod-down-ls dn-ls)
+(define mod-int? int?)
+
+(define (i-or-x module)
+ (if (int? module) 'i 'x))
+
+(define edge-type (make-object-property)) ; symbol
+
+(define (make-edge type up down)
+ (let ((new (cons up down)))
+ (set! (edge-type new) type)
+ new))
+
+(define edge-up car)
+(define edge-down cdr)
+
+(define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
+(define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
+
+(define (make-body alist)
+ (lambda (key)
+ (assq-ref alist key)))
+
+(define (scan default-module files)
+ (let* ((modules (list))
+ (edges (list))
+ (intern (lambda (module)
+ (cond ((member module modules) => car)
+ (else (set! (up-ls module) (list))
+ (set! (dn-ls module) (list))
+ (set! modules (cons module modules))
+ module))))
+ (grok (grok-proc default-module
+ (lambda (type d u)
+ (let ((d (intern d)))
+ (if (eq? type 'def)
+ (set! (int? d) #t)
+ (let* ((u (intern u))
+ (edge (make-edge type u d)))
+ (set! edges (cons edge edges))
+ (up-ls+! d edge)
+ (dn-ls+! u edge))))))))
+ (for-each grok files)
+ (make-body
+ `((modules . ,modules)
+ (internal . ,(filter int? modules))
+ (external . ,(remove int? modules))
+ (i-up . ,(filter int? (map edge-down edges)))
+ (x-up . ,(remove int? (map edge-down edges)))
+ (i-down . ,(filter int? (map edge-up edges)))
+ (x-down . ,(remove int? (map edge-up edges)))
+ (edges . ,edges)))))
+
+(define (make-frisker . options)
+ (let ((default-module (or (assq-ref options 'default-module)
+ *default-module*)))
+ (lambda (files)
+ (scan default-module files))))
+
+(define (dump-updown modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A --- ~A --- ~A\n"
+ (i-or-x m) m
+ (map (lambda (edge)
+ (cons (edge-type edge)
+ (edge-up edge)))
+ (up-ls m))
+ (map (lambda (edge)
+ (cons (edge-type edge)
+ (edge-down edge)))
+ (dn-ls m))))
+ modules))
+
+(define (dump-up modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A\n" (i-or-x m) m)
+ (for-each (lambda (edge)
+ (format #t "\t\t\t ~A\t~A\n"
+ (edge-type edge) (edge-up edge)))
+ (up-ls m)))
+ modules))
+
+(define (dump-down modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A\n" (i-or-x m) m)
+ (for-each (lambda (edge)
+ (format #t "\t\t\t ~A\t~A\n"
+ (edge-type edge) (edge-down edge)))
+ (dn-ls m)))
+ modules))
+
+(define (frisk . args)
+ (let* ((parsed-opts (getopt-long
+ (cons "frisk" args) ;;; kludge
+ '((upstream (single-char #\u))
+ (downstream (single-char #\d))
+ (internal (single-char #\i))
+ (external (single-char #\x))
+ (default-module
+ (single-char #\m)
+ (value #t)))))
+ (=u (option-ref parsed-opts 'upstream #f))
+ (=d (option-ref parsed-opts 'downstream #f))
+ (=i (option-ref parsed-opts 'internal #f))
+ (=x (option-ref parsed-opts 'external #f))
+ (files (option-ref parsed-opts '() (list)))
+ (report ((make-frisker
+ `(default-module
+ . ,(option-ref parsed-opts 'default-module
+ *default-module*)))
+ files))
+ (modules (report 'modules))
+ (internal (report 'internal))
+ (external (report 'external))
+ (edges (report 'edges)))
+ (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
+ (length files) "files"
+ (length modules) "modules"
+ (length internal) "internal"
+ (length external) "external"
+ (length edges) "edges")
+ ((cond ((and =u =d) dump-updown)
+ (=u dump-up)
+ (else dump-down))
+ (cond ((and =i =x) modules)
+ (=i internal)
+ (else external)))))
+
+(define main frisk)
+
+;;; frisk ends here
projects / lilypond.git / blobdiff