35 |
;; |
;; |
36 |
;; An `:autoload' `define-module'-component results in a "dotted" style edge |
;; An `:autoload' `define-module'-component results in a "dotted" style edge |
37 |
;; with label "N" indicating that N names are responsible for triggering the |
;; with label "N" indicating that N names are responsible for triggering the |
38 |
;; autoload. |
;; autoload. [The "N" label is not implemented.] |
39 |
;; |
;; |
40 |
;; A top-level `load' or `primitive-load' form results in a a "bold" style |
;; 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 |
;; edge to a node named with either the file name if the `load' argument is a |
47 |
;; `define-module' form in a file). MOD should be |
;; `define-module' form in a file). MOD should be |
48 |
;; be a list or `#f', in which case such top-level |
;; be a list or `#f', in which case such top-level |
49 |
;; `use-modules' forms are effectively ignored. |
;; `use-modules' forms are effectively ignored. |
50 |
;; Default value: `(guile)'. |
;; Default value: `(guile-user)'. |
51 |
;; |
;; |
52 |
;; TODO |
;; TODO: Use `(ice-9 format)'. |
|
;; - add `--load-synonyms' option |
|
|
;; - add `--ignore-module' option |
|
|
;; - handle arbitrary command-line key/value configuration |
|
53 |
|
|
54 |
;;; Code: |
;;; Code: |
55 |
|
|
56 |
(define-module (scripts use2dot) |
(define-module (scripts use2dot) |
57 |
:use-module (ice-9 regex)) |
:use-module ((scripts frisk) |
58 |
|
:select (make-frisker edge-type edge-up edge-down))) |
59 |
|
|
60 |
|
(define *default-module* '(guile-user)) |
61 |
|
|
62 |
(define (string-append/separator separator strings) |
(define (string-append/separator separator strings) |
63 |
;; from (ttn stringutils) -- todo: use srfi-13 |
;; from (ttn stringutils) -- todo: use srfi-13 |
81 |
;; "Map PROC over LS, concatening resulting strings with separator SEP." |
;; "Map PROC over LS, concatening resulting strings with separator SEP." |
82 |
(string-append/separator sep (map proc ls))) |
(string-append/separator sep (map proc ls))) |
83 |
|
|
|
(define default-module '(guile)) |
|
|
|
|
84 |
(define (q s) ; quote |
(define (q s) ; quote |
85 |
(format #f "~S" s)) |
(format #f "~S" s)) |
86 |
|
|
87 |
(define (vv pair) ; var=val |
(define (vv pair) ; var=val |
88 |
(format #f "~A=~A" (car pair) (cdr pair))) |
(format #f "~A=~A" (car pair) (cdr pair))) |
89 |
|
|
90 |
(define (spew module use . etc) |
(define (>>header) |
|
(and module |
|
|
(let ((etc-spec (if (null? etc) |
|
|
"" |
|
|
(format #f " [~A]" (mapconcat vv etc ","))))) |
|
|
(format #t " \"~A\" -> \"~A\"~A;\n" module use etc-spec)))) |
|
|
|
|
|
(define (header) |
|
91 |
(format #t "digraph use2dot {\n") |
(format #t "digraph use2dot {\n") |
92 |
(for-each (lambda (s) (format #t " ~A;\n" s)) |
(for-each (lambda (s) (format #t " ~A;\n" s)) |
93 |
(map vv `((label . ,(q "Guile Module Dependencies")) |
(map vv `((label . ,(q "Guile Module Dependencies")) |
94 |
;(rankdir . LR) |
;;(rankdir . LR) |
95 |
;(size . ,(q "7.5,10")) |
;;(size . ,(q "7.5,10")) |
96 |
(ratio . fill) |
(ratio . fill) |
97 |
;(nodesep . ,(q "0.05")) |
;;(nodesep . ,(q "0.05")) |
98 |
)))) |
)))) |
99 |
|
|
100 |
(define (ferret use) ; handle "((foo bar) :select ...)" |
(define (>>body edges) |
101 |
(let ((maybe (car use))) |
(for-each |
102 |
(if (list? maybe) |
(lambda (edge) |
103 |
maybe |
(format #t " \"~A\" -> \"~A\"" (edge-down edge) (edge-up edge)) |
104 |
use))) |
(cond ((case (edge-type edge) |
105 |
|
((autoload) '((style . dotted) (fontsize . 5))) |
106 |
(define (grok filename) |
((computed) '((style . bold))) |
107 |
(let* ((p (open-file filename "r")) |
(else #f)) |
108 |
(next (lambda () (read p))) |
=> (lambda (etc) |
109 |
(curmod #f)) |
(format #t " [~A]" (mapconcat vv etc ","))))) |
110 |
(let loop ((form (next))) |
(format #t ";\n")) |
111 |
(cond ((eof-object? form)) |
edges)) |
|
((not (list? form)) (loop (next))) |
|
|
(else (case (car form) |
|
|
((define-module) |
|
|
(let ((module (cadr form))) |
|
|
(set! curmod module) |
|
|
(let loop ((ls form)) |
|
|
(or (null? ls) |
|
|
(case (car ls) |
|
|
((:use-module) |
|
|
(spew module (ferret (cadr ls))) |
|
|
(loop (cddr ls))) |
|
|
((:autoload) |
|
|
(spew module (cadr ls) |
|
|
'(style . dotted) |
|
|
'(fontsize . 5) |
|
|
(let ((len (length (caddr ls)))) |
|
|
`(label . ,(q (number->string len))))) |
|
|
(loop (cdddr ls))) |
|
|
(else (loop (cdr ls)))))))) |
|
|
((use-modules) |
|
|
(for-each (lambda (use) |
|
|
(spew (or curmod default-module) |
|
|
(ferret use))) |
|
|
(cdr form))) |
|
|
((load primitive-load) |
|
|
(spew (or curmod default-module) |
|
|
(let ((file (cadr form))) |
|
|
(if (string? file) |
|
|
file |
|
|
(format #f "[computed in ~A]" filename))) |
|
|
'(style . bold)))) |
|
|
(loop (next))))))) |
|
|
|
|
|
(define (body files) |
|
|
(for-each grok files)) |
|
112 |
|
|
113 |
(define (footer) |
(define (>>footer) |
114 |
(format #t "}")) |
(format #t "}")) |
115 |
|
|
116 |
(define (use2dot . args) |
(define (use2dot . args) |
117 |
(header) |
(let* ((override (cond ((member "--default-module" args) |
118 |
(let* ((override (cond ((member "--default-module" args) => cadr) |
=> (lambda (ls) |
119 |
|
(with-input-from-string |
120 |
|
(cadr ls) |
121 |
|
(lambda () (read))))) |
122 |
(else #f))) |
(else #f))) |
123 |
(files (if override (cddr args) args))) |
(files (if override (cddr args) args))) |
124 |
(and override |
(>>header) |
125 |
(set! default-module |
(>>body (reverse |
126 |
(with-input-from-string override (lambda () (read))))) |
(((make-frisker |
127 |
(body files)) |
`(default-module . ,(or override *default-module*))) |
128 |
(footer)) |
files) |
129 |
|
'edges))) |
130 |
|
(>>footer))) |
131 |
|
|
132 |
(define main use2dot) |
(define main use2dot) |
133 |
|
|