/[guile]/guile/guile-core/scripts/use2dot
ViewVC logotype

Diff of /guile/guile-core/scripts/use2dot

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by ttn, Thu Nov 29 00:19:13 2001 UTC revision 1.7 by ttn, Tue Jan 8 03:39:04 2002 UTC
# Line 35  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 35  exec ${GUILE-guile} -l $0 -c "(apply $ma
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
# Line 47  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 47  exec ${GUILE-guile} -l $0 -c "(apply $ma
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
# Line 81  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 81  exec ${GUILE-guile} -l $0 -c "(apply $ma
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    

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26