mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
a1a2ed5342
* module/scripts/: Add %summary entries, and in many cases, %include-in-guild-list entries to inhibit a script from appearing in "guild list". Update list.scm to respect this new variable.
290 lines
11 KiB
Scheme
290 lines
11 KiB
Scheme
;;; 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
|