;;; frisk --- Grok the module interfaces of a body of files
;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
;; as published by the Free Software Foundation; either version 3, 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this software; see the file COPYING.LESSER. 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 %include-in-guild-list #f)
(define %summary "Show dependency information for a module.")
(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 :use-module)
(note-use! 'regular module (ferret (cadr ls)))
(loop (cddr ls)))
((#:autoload :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