Commit | Line | Data |
---|---|---|
ce5fb40c TTN |
1 | #!/bin/sh |
2 | # aside from this initial boilerplate, this is actually -*- scheme -*- code | |
3 | main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')' | |
4 | exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" | |
5 | !# | |
6 | ;;; frisk --- Grok the module interfaces of a body of files | |
7 | ||
6e7d5622 | 8 | ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. |
ce5fb40c TTN |
9 | ;; |
10 | ;; This program is free software; you can redistribute it and/or | |
11 | ;; modify it under the terms of the GNU General Public License as | |
12 | ;; published by the Free Software Foundation; either version 2, or | |
13 | ;; (at your option) any later version. | |
14 | ;; | |
15 | ;; This program is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
18 | ;; General Public License for more details. | |
19 | ;; | |
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with this software; see the file COPYING. If not, write to | |
92205699 MV |
22 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 | ;; Boston, MA 02110-1301 USA | |
ce5fb40c TTN |
24 | |
25 | ;;; Author: Thien-Thi Nguyen <ttn@gnu.org> | |
26 | ||
27 | ;;; Commentary: | |
28 | ||
29 | ;; Usage: frisk [options] file ... | |
30 | ;; | |
31 | ;; Analyze FILE... module interfaces in aggregate (as a "body"), | |
32 | ;; and display a summary. Modules that are `define-module'd are | |
33 | ;; considered "internal" (and those not, "external"). When module X | |
34 | ;; uses module Y, X is said to be "(a) downstream of" Y, and Y is | |
35 | ;; "(an) upstream of" X. | |
36 | ;; | |
37 | ;; Normally, the summary displays external modules and their internal | |
38 | ;; downstreams, as this is the usual question asked by a body. There | |
39 | ;; are several options that modify this output. | |
40 | ;; | |
41 | ;; -u, --upstream show upstream edges | |
42 | ;; -d, --downstream show downstream edges (default) | |
43 | ;; -i, --internal show internal modules | |
44 | ;; -x, --external show external modules (default) | |
45 | ;; | |
46 | ;; If given both `upstream' and `downstream' options ("frisk -ud"), the | |
47 | ;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is | |
48 | ;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE | |
49 | ;; MODULE-NAME ...). | |
50 | ;; | |
51 | ;; In all other cases, the "C MODULE" occupies its own line, and | |
52 | ;; subsequent lines list the up- or downstream edges, respectively, | |
53 | ;; indented by some non-zero amount of whitespace. | |
54 | ;; | |
55 | ;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a | |
56 | ;; file that do not follow a `define-module' result an edge where the | |
57 | ;; downstream is the "default module", normally `(guile-user)'. This | |
58 | ;; can be set to another value by using: | |
59 | ;; | |
60 | ;; -m, --default-module MOD set MOD as the default module | |
61 | ||
62 | ;; Usage from a Scheme Program: (use-modules (scripts frisk)) | |
63 | ;; | |
64 | ;; Module export list: | |
65 | ;; (frisk . args) | |
66 | ;; (make-frisker . options) => (lambda (files) ...) [see below] | |
67 | ;; (mod-up-ls module) => upstream edges | |
b51e3634 | 68 | ;; (mod-down-ls module) => downstream edges |
ce5fb40c TTN |
69 | ;; (mod-int? module) => is the module internal? |
70 | ;; (edge-type edge) => symbol: {regular,autoload,computed} | |
71 | ;; (edge-up edge) => upstream module | |
72 | ;; (edge-down edge) => downstream module | |
73 | ;; | |
74 | ;; OPTIONS is an alist. Recognized keys are: | |
75 | ;; default-module | |
76 | ;; | |
77 | ;; `make-frisker' returns a procedure that takes a list of files, the | |
78 | ;; FRISKER. FRISKER returns a closure, REPORT, that takes one of the | |
79 | ;; keys: | |
80 | ;; modules -- entire list of modules | |
81 | ;; internal -- list of internal modules | |
82 | ;; external -- list of external modules | |
83 | ;; i-up -- list of modules upstream of internal modules | |
84 | ;; x-up -- list of modules upstream of external modules | |
85 | ;; i-down -- list of modules downstream of internal modules | |
86 | ;; x-down -- list of modules downstream of external modules | |
87 | ;; edges -- list of edges | |
88 | ;; Note that `x-up' should always be null, since by (lack of!) | |
89 | ;; definition, we only know external modules by reference. | |
90 | ;; | |
91 | ;; The module and edge objects managed by REPORT can be examined in | |
92 | ;; detail by using the other (self-explanatory) procedures. Be careful | |
93 | ;; not to confuse a freshly consed list of symbols, like `(a b c)' with | |
94 | ;; the module `(a b c)'. If you want to find the module by that name, | |
95 | ;; try: (cond ((member '(a b c) (REPORT 'modules)) => car)). | |
96 | ||
97 | ;; TODO: Make "frisk -ud" output less ugly. | |
98 | ;; Consider default module as internal; add option to invert. | |
99 | ;; Support `edge-misc' data. | |
100 | ||
101 | ;;; Code: | |
102 | ||
103 | (define-module (scripts frisk) | |
104 | :autoload (ice-9 getopt-long) (getopt-long) | |
105 | :use-module ((srfi srfi-1) :select (filter remove)) | |
106 | :export (frisk | |
107 | make-frisker | |
108 | mod-up-ls mod-down-ls mod-int? | |
109 | edge-type edge-up edge-down)) | |
110 | ||
111 | (define *default-module* '(guile-user)) | |
112 | ||
113 | (define (grok-proc default-module note-use!) | |
114 | (lambda (filename) | |
115 | (let* ((p (open-file filename "r")) | |
116 | (next (lambda () (read p))) | |
117 | (ferret (lambda (use) ;;; handle "((foo bar) :select ...)" | |
118 | (let ((maybe (car use))) | |
119 | (if (list? maybe) | |
120 | maybe | |
121 | use)))) | |
122 | (curmod #f)) | |
123 | (let loop ((form (next))) | |
124 | (cond ((eof-object? form)) | |
125 | ((not (list? form)) (loop (next))) | |
126 | (else (case (car form) | |
127 | ((define-module) | |
128 | (let ((module (cadr form))) | |
129 | (set! curmod module) | |
130 | (note-use! 'def module #f) | |
131 | (let loop ((ls form)) | |
132 | (or (null? ls) | |
133 | (case (car ls) | |
134 | ((:use-module) | |
135 | (note-use! 'regular module (ferret (cadr ls))) | |
136 | (loop (cddr ls))) | |
137 | ((:autoload) | |
138 | (note-use! 'autoload module (cadr ls)) | |
139 | (loop (cdddr ls))) | |
140 | (else (loop (cdr ls)))))))) | |
141 | ((use-modules) | |
142 | (for-each (lambda (use) | |
143 | (note-use! 'regular | |
144 | (or curmod default-module) | |
145 | (ferret use))) | |
146 | (cdr form))) | |
147 | ((load primitive-load) | |
148 | (note-use! 'computed | |
149 | (or curmod default-module) | |
150 | (let ((file (cadr form))) | |
151 | (if (string? file) | |
152 | file | |
153 | (format #f "[computed in ~A]" | |
154 | filename)))))) | |
155 | (loop (next)))))))) | |
156 | ||
157 | (define up-ls (make-object-property)) ; list | |
158 | (define dn-ls (make-object-property)) ; list | |
159 | (define int? (make-object-property)) ; defined via `define-module' | |
160 | ||
161 | (define mod-up-ls up-ls) | |
162 | (define mod-down-ls dn-ls) | |
163 | (define mod-int? int?) | |
164 | ||
165 | (define (i-or-x module) | |
166 | (if (int? module) 'i 'x)) | |
167 | ||
168 | (define edge-type (make-object-property)) ; symbol | |
169 | ||
170 | (define (make-edge type up down) | |
171 | (let ((new (cons up down))) | |
172 | (set! (edge-type new) type) | |
173 | new)) | |
174 | ||
175 | (define edge-up car) | |
176 | (define edge-down cdr) | |
177 | ||
178 | (define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m)))) | |
179 | (define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m)))) | |
180 | ||
181 | (define (make-body alist) | |
182 | (lambda (key) | |
183 | (assq-ref alist key))) | |
184 | ||
185 | (define (scan default-module files) | |
186 | (let* ((modules (list)) | |
187 | (edges (list)) | |
188 | (intern (lambda (module) | |
189 | (cond ((member module modules) => car) | |
190 | (else (set! (up-ls module) (list)) | |
191 | (set! (dn-ls module) (list)) | |
192 | (set! modules (cons module modules)) | |
193 | module)))) | |
194 | (grok (grok-proc default-module | |
195 | (lambda (type d u) | |
196 | (let ((d (intern d))) | |
197 | (if (eq? type 'def) | |
198 | (set! (int? d) #t) | |
199 | (let* ((u (intern u)) | |
200 | (edge (make-edge type u d))) | |
201 | (set! edges (cons edge edges)) | |
202 | (up-ls+! d edge) | |
203 | (dn-ls+! u edge)))))))) | |
204 | (for-each grok files) | |
205 | (make-body | |
206 | `((modules . ,modules) | |
207 | (internal . ,(filter int? modules)) | |
208 | (external . ,(remove int? modules)) | |
209 | (i-up . ,(filter int? (map edge-down edges))) | |
210 | (x-up . ,(remove int? (map edge-down edges))) | |
211 | (i-down . ,(filter int? (map edge-up edges))) | |
212 | (x-down . ,(remove int? (map edge-up edges))) | |
213 | (edges . ,edges))))) | |
214 | ||
215 | (define (make-frisker . options) | |
216 | (let ((default-module (or (assq-ref options 'default-module) | |
217 | *default-module*))) | |
218 | (lambda (files) | |
219 | (scan default-module files)))) | |
220 | ||
221 | (define (dump-updown modules) | |
222 | (for-each (lambda (m) | |
223 | (format #t "~A ~A --- ~A --- ~A\n" | |
224 | (i-or-x m) m | |
225 | (map (lambda (edge) | |
226 | (cons (edge-type edge) | |
227 | (edge-up edge))) | |
228 | (up-ls m)) | |
229 | (map (lambda (edge) | |
230 | (cons (edge-type edge) | |
231 | (edge-down edge))) | |
232 | (dn-ls m)))) | |
233 | modules)) | |
234 | ||
235 | (define (dump-up modules) | |
236 | (for-each (lambda (m) | |
237 | (format #t "~A ~A\n" (i-or-x m) m) | |
238 | (for-each (lambda (edge) | |
239 | (format #t "\t\t\t ~A\t~A\n" | |
240 | (edge-type edge) (edge-up edge))) | |
241 | (up-ls m))) | |
242 | modules)) | |
243 | ||
244 | (define (dump-down modules) | |
245 | (for-each (lambda (m) | |
246 | (format #t "~A ~A\n" (i-or-x m) m) | |
247 | (for-each (lambda (edge) | |
248 | (format #t "\t\t\t ~A\t~A\n" | |
249 | (edge-type edge) (edge-down edge))) | |
250 | (dn-ls m))) | |
251 | modules)) | |
252 | ||
253 | (define (frisk . args) | |
254 | (let* ((parsed-opts (getopt-long | |
255 | (cons "frisk" args) ;;; kludge | |
256 | '((upstream (single-char #\u)) | |
257 | (downstream (single-char #\d)) | |
258 | (internal (single-char #\i)) | |
259 | (external (single-char #\x)) | |
260 | (default-module | |
261 | (single-char #\m) | |
262 | (value #t))))) | |
263 | (=u (option-ref parsed-opts 'upstream #f)) | |
264 | (=d (option-ref parsed-opts 'downstream #f)) | |
265 | (=i (option-ref parsed-opts 'internal #f)) | |
266 | (=x (option-ref parsed-opts 'external #f)) | |
267 | (files (option-ref parsed-opts '() (list))) | |
268 | (report ((make-frisker | |
269 | `(default-module | |
270 | . ,(option-ref parsed-opts 'default-module | |
271 | *default-module*))) | |
272 | files)) | |
273 | (modules (report 'modules)) | |
274 | (internal (report 'internal)) | |
275 | (external (report 'external)) | |
276 | (edges (report 'edges))) | |
277 | (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n" | |
278 | (length files) "files" | |
279 | (length modules) "modules" | |
280 | (length internal) "internal" | |
281 | (length external) "external" | |
282 | (length edges) "edges") | |
283 | ((cond ((and =u =d) dump-updown) | |
284 | (=u dump-up) | |
285 | (else dump-down)) | |
286 | (cond ((and =i =x) modules) | |
287 | (=i internal) | |
288 | (else external))))) | |
289 | ||
290 | (define main frisk) | |
291 | ||
292 | ;;; frisk ends here |