source: project/nest-tool/trunk/nest-tool.scm @ 5797

Last change on this file since 5797 was 5797, checked in by Mario Domenech Goulart, 13 years ago

Experimental dependencies graph generation.

File size: 3.6 KB
Line 
1(use http-client srfi-1)
2(declare (uses utils regex))
3
4(define nest-tool:repository (make-parameter "http://www.call-with-current-continuation.org/eggs/repository"))
5
6(define (nest-tool:raw)
7  (with-input-from-string
8      (if (file-exists? (nest-tool:repository))
9          (read-all (nest-tool:repository))
10          (http:GET (nest-tool:repository)))
11    read))
12
13(define (nest-tool:egg-name egg)
14  (car egg))
15
16(define (nest-tool:egg-date egg)
17  (cadar (cadr egg)))
18
19(define (nest-tool:egg-file egg)
20  (caddr egg))
21
22(define (nest-tool:egg-dependencies egg)
23  (drop egg 3))
24
25(define (nest-tool:names #!optional raw)
26  (map nest-tool:egg-name (or raw (nest-tool:raw))))
27
28(define (nest-tool:dates #!optional raw)
29  (map (lambda (egg)
30         (cons (nest-tool:egg-name egg) (nest-tool:egg-date egg)))
31       (or raw (nest-tool:raw))))
32
33(define (nest-tool:files #!optional raw)
34  (map (lambda (egg)
35         (cons (nest-tool:egg-name egg) (nest-tool:egg-file egg)))
36       (or raw (nest-tool:raw))))
37
38(define (nest-tool:dependencies #!optional raw)
39  (map (lambda (egg)
40         (cons (nest-tool:egg-name egg) (nest-tool:egg-dependencies egg)))
41       (or raw (nest-tool:raw))))
42
43(define (nest-tool:search-names pattern #!optional raw)
44  (filter (lambda (egg)
45            (string-match pattern (symbol->string (car egg))))
46          (nest-tool:raw)))
47
48(define (nest-tool:search-dependencies pattern #!optional raw)
49  (filter (lambda (egg)
50            (not (null? (grep pattern (map symbol->string (nest-tool:egg-dependencies egg))))))
51          (nest-tool:raw)))
52
53(define (nest-tool:dep-graph->dot eggname #!key (raw #f))
54  (define labels "")
55  (define links '())
56 
57  (define (scm->dot name)
58    (cond ((eq? name 'digraph) "digraph_")
59          ((equal? name "digraph") "digraph_")
60          (else (string-translate (->string name) "-" "_"))))
61
62  (define (add-link! from to)
63    (unless (member (cons from to) links)
64      (set! links (cons (cons from to) links))))
65
66  (define (links->string)
67    (string-intersperse
68     (map (lambda (link)
69            (string-append (scm->dot (car link)) " -> "
70                           (scm->dot (cdr link)) ";\n"))
71          links)))
72   
73  (define (link-dependencies egg)
74    (let ((deps (filter (lambda (egg)
75                          (not (memq egg ##sys#core-library-modules)))
76                        (nest-tool:egg-dependencies (car (nest-tool:search-names (->string egg) raw))))))
77      (with-output-to-string
78        (lambda ()
79          (let ((dot-egg (scm->dot egg)))
80            (set! labels (string-append labels dot-egg " [label=\"" (->string egg) "\"]\n"))
81            (for-each (lambda (egg-dep)
82                        (add-link! egg egg-dep)
83                        (link-dependencies egg-dep))
84                      deps))))))
85  (link-dependencies eggname)
86  (string-append "digraph eggs {\n" labels "\n" (links->string) "\n}"))
87
88(define (nest-tool:dep-graphs->graphic eggname #!key (output-dir ".") (raw #f) (format 'png))
89  (with-output-to-file  (make-pathname output-dir (->string eggname) "dot")
90    (lambda ()
91      (print (nest-tool:dep-graph->dot eggname raw: raw))))
92  (system (conc "dot -T" format " "
93                " -o " (make-pathname output-dir eggname (->string format)) " "
94                (make-pathname output-dir eggname "dot")
95                " &")))
96
97(define (nest-tool:all-dep-graphs->graphic #!key (eggnames #f) (output-dir ".") (format 'png))
98  (let ((raw (nest-tool:raw)))
99    (for-each (lambda (egg)
100                (nest-tool:dep-graphs->graphic egg output-dir: output-dir raw: raw format: format))
101              (map ->string (or eggnames (nest-tool:names))))))
Note: See TracBrowser for help on using the repository browser.