Commit | Line | Data |
---|---|---|
28c31342 TTN |
1 | #!/bin/sh |
2 | # aside from this initial boilerplate, this is actually -*- scheme -*- code | |
3 | main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')' | |
4 | exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" | |
5 | !# | |
6 | ;;; use2dot --- Display module dependencies as a DOT specification | |
7 | ||
8 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
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 | |
22 | ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
23 | ;; Boston, MA 02111-1307 USA | |
24 | ||
61897afe TTN |
25 | ;;; Author: Thien-Thi Nguyen |
26 | ||
28c31342 TTN |
27 | ;;; Commentary: |
28 | ||
29 | ;; Usage: use2dot [OPTIONS] [FILE ...] | |
30 | ;; Display to stdout a DOT specification that describes module dependencies | |
31 | ;; in FILEs. | |
32 | ;; | |
33 | ;; A top-level `use-modules' form or a `:use-module' `define-module'-component | |
34 | ;; results in a "solid" style edge. | |
35 | ;; | |
36 | ;; An `:autoload' `define-module'-component results in a "dotted" style edge | |
37 | ;; with label "N" indicating that N names are responsible for triggering the | |
38 | ;; autoload. | |
39 | ;; | |
40 | ;; A top-level `load' or `primitive-load' form results in a a "bold" style | |
41 | ;; edge to a node named with either the file name if the `load' argument is a | |
42 | ;; string, or "[computed in FILE]" otherwise. | |
43 | ;; | |
44 | ;; Options: | |
45 | ;; --default-module MOD -- Set MOD as the default module (for top-level | |
46 | ;; `use-modules' forms that do not follow some | |
47 | ;; `define-module' form in a file). MOD should be | |
48 | ;; be a list or `#f', in which case such top-level | |
49 | ;; `use-modules' forms are effectively ignored. | |
50 | ;; Default value: `(guile)'. | |
51 | ;; | |
52 | ;; TODO | |
53 | ;; - add `--load-synonyms' option | |
54 | ;; - add `--ignore-module' option | |
55 | ;; - handle arbitrary command-line key/value configuration | |
28c31342 TTN |
56 | |
57 | ;;; Code: | |
58 | ||
59 | (define-module (scripts use2dot) | |
60 | :use-module (ice-9 regex)) | |
61 | ||
62 | (define (string-append/separator separator strings) | |
63 | ;; from (ttn stringutils) -- todo: use srfi-13 | |
64 | ;; "Append w/ SEPARATOR a list of STRINGS. | |
65 | ;; SEPARATOR can be a character or a string." | |
66 | (let ((rev (reverse strings)) | |
67 | (sep (if (char? separator) | |
68 | (make-string 1 separator) | |
69 | separator))) | |
70 | (apply string-append | |
71 | (let loop ((s (cdr rev)) | |
72 | (acc (list (car rev)))) | |
73 | (if (null? s) | |
74 | acc | |
75 | (loop (cdr s) | |
76 | (cons (car s) | |
77 | (cons sep acc)))))))) | |
78 | ||
79 | (define (mapconcat proc ls sep) | |
80 | ;; from (ttn stringutils) -- todo: use srfi-13 | |
81 | ;; "Map PROC over LS, concatening resulting strings with separator SEP." | |
82 | (string-append/separator sep (map proc ls))) | |
83 | ||
84 | (define default-module '(guile)) | |
85 | ||
86 | (define (q s) ; quote | |
87 | (format #f "~S" s)) | |
88 | ||
89 | (define (vv pair) ; var=val | |
90 | (format #f "~A=~A" (car pair) (cdr pair))) | |
91 | ||
92 | (define (spew module use . etc) | |
93 | (and module | |
94 | (let ((etc-spec (if (null? etc) | |
95 | "" | |
96 | (format #f " [~A]" (mapconcat vv etc ","))))) | |
97 | (format #t " \"~A\" -> \"~A\"~A;\n" module use etc-spec)))) | |
98 | ||
99 | (define (header) | |
100 | (format #t "digraph use2dot {") | |
101 | (for-each (lambda (s) (format #t " ~A;\n" s)) | |
102 | (map vv `((label . ,(q "Guile Module Dependencies")) | |
103 | ;(rankdir . LR) | |
104 | ;(size . ,(q "7.5,10")) | |
105 | (ratio . fill) | |
106 | ;(nodesep . ,(q "0.05")) | |
107 | )))) | |
108 | ||
109 | (define (grok filename) | |
110 | (let* ((p (open-file filename "r")) | |
111 | (next (lambda () (read p))) | |
112 | (curmod #f)) | |
113 | (let loop ((form (next))) | |
114 | (cond ((eof-object? form)) | |
115 | ((not (list? form)) (loop (next))) | |
116 | (else (case (car form) | |
117 | ((define-module) | |
118 | (let ((module (cadr form))) | |
119 | (set! curmod module) | |
120 | (let loop ((ls form)) | |
121 | (or (null? ls) | |
122 | (case (car ls) | |
123 | ((:use-module) | |
124 | (spew module (cadr ls)) | |
125 | (loop (cddr ls))) | |
126 | ((:autoload) | |
127 | (spew module (cadr ls) | |
128 | '(style . dotted) | |
129 | '(fontsize . 5) | |
130 | (let ((len (length (caddr ls)))) | |
131 | `(label . ,(q (number->string len))))) | |
132 | (loop (cdddr ls))) | |
133 | (else (loop (cdr ls)))))))) | |
134 | ((use-modules) | |
135 | (for-each (lambda (use) | |
136 | (spew (or curmod default-module) use)) | |
137 | (cdr form))) | |
138 | ((load primitive-load) | |
139 | (spew (or curmod default-module) | |
140 | (let ((file (cadr form))) | |
141 | (if (string? file) | |
142 | file | |
143 | (format #f "[computed in ~A]" filename))) | |
144 | '(style . bold)))) | |
145 | (loop (next))))))) | |
146 | ||
147 | (define (body files) | |
148 | (for-each grok files)) | |
149 | ||
150 | (define (footer) | |
151 | (format #t "}")) | |
152 | ||
153 | (define (use2dot . args) | |
154 | (header) | |
155 | (let* ((override (cond ((member "--default-module" args) => cadr) | |
156 | (else #f))) | |
157 | (files (if override (cddr args) args))) | |
158 | (and override | |
159 | (set! default-module | |
160 | (with-input-from-string override (lambda () (read))))) | |
161 | (body files)) | |
162 | (footer)) | |
163 | ||
164 | (define main use2dot) | |
165 | ||
166 | ;;; use2dot ends here |