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