123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291 |
- (define-module (scripts frisk)
- :autoload (ice-9 getopt-long) (getopt-long)
- :use-module ((srfi srfi-1) :select (filter remove))
- :export (frisk
- make-frisker
- mod-up-ls mod-down-ls mod-int?
- edge-type edge-up edge-down))
- (define %include-in-guild-list #f)
- (define %summary "Show dependency information for a module.")
- (define *default-module* '(guile-user))
- (define (grok-proc default-module note-use!)
- (lambda (filename)
- (let* ((p (open-file filename "r"))
- (next (lambda () (read p)))
- (ferret (lambda (use)
- (let ((maybe (car use)))
- (if (list? maybe)
- maybe
- use))))
- (curmod #f))
- (let loop ((form (next)))
- (cond ((eof-object? form))
- ((not (list? form)) (loop (next)))
- (else (case (car form)
- ((define-module)
- (let ((module (cadr form)))
- (set! curmod module)
- (note-use! 'def module #f)
- (let loop ((ls form))
- (or (null? ls)
- (case (car ls)
- ((#:use-module :use-module)
- (note-use! 'regular module (ferret (cadr ls)))
- (loop (cddr ls)))
- ((#:autoload :autoload)
- (note-use! 'autoload module (cadr ls))
- (loop (cdddr ls)))
- (else (loop (cdr ls))))))))
- ((use-modules)
- (for-each (lambda (use)
- (note-use! 'regular
- (or curmod default-module)
- (ferret use)))
- (cdr form)))
- ((load primitive-load)
- (note-use! 'computed
- (or curmod default-module)
- (let ((file (cadr form)))
- (if (string? file)
- file
- (format #f "[computed in ~A]"
- filename))))))
- (loop (next))))))))
- (define up-ls (make-object-property))
- (define dn-ls (make-object-property))
- (define int? (make-object-property))
- (define mod-up-ls up-ls)
- (define mod-down-ls dn-ls)
- (define mod-int? int?)
- (define (i-or-x module)
- (if (int? module) 'i 'x))
- (define edge-type (make-object-property))
- (define (make-edge type up down)
- (let ((new (cons up down)))
- (set! (edge-type new) type)
- new))
- (define edge-up car)
- (define edge-down cdr)
- (define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
- (define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
- (define (make-body alist)
- (lambda (key)
- (assq-ref alist key)))
- (define (scan default-module files)
- (let* ((modules (list))
- (edges (list))
- (intern (lambda (module)
- (cond ((member module modules) => car)
- (else (set! (up-ls module) (list))
- (set! (dn-ls module) (list))
- (set! modules (cons module modules))
- module))))
- (grok (grok-proc default-module
- (lambda (type d u)
- (let ((d (intern d)))
- (if (eq? type 'def)
- (set! (int? d) #t)
- (let* ((u (intern u))
- (edge (make-edge type u d)))
- (set! edges (cons edge edges))
- (up-ls+! d edge)
- (dn-ls+! u edge))))))))
- (for-each grok files)
- (make-body
- `((modules . ,modules)
- (internal . ,(filter int? modules))
- (external . ,(remove int? modules))
- (i-up . ,(filter int? (map edge-down edges)))
- (x-up . ,(remove int? (map edge-down edges)))
- (i-down . ,(filter int? (map edge-up edges)))
- (x-down . ,(remove int? (map edge-up edges)))
- (edges . ,edges)))))
- (define (make-frisker . options)
- (let ((default-module (or (assq-ref options 'default-module)
- *default-module*)))
- (lambda (files)
- (scan default-module files))))
- (define (dump-updown modules)
- (for-each (lambda (m)
- (format #t "~A ~A --- ~A --- ~A\n"
- (i-or-x m) m
- (map (lambda (edge)
- (cons (edge-type edge)
- (edge-up edge)))
- (up-ls m))
- (map (lambda (edge)
- (cons (edge-type edge)
- (edge-down edge)))
- (dn-ls m))))
- modules))
- (define (dump-up modules)
- (for-each (lambda (m)
- (format #t "~A ~A\n" (i-or-x m) m)
- (for-each (lambda (edge)
- (format #t "\t\t\t ~A\t~A\n"
- (edge-type edge) (edge-up edge)))
- (up-ls m)))
- modules))
- (define (dump-down modules)
- (for-each (lambda (m)
- (format #t "~A ~A\n" (i-or-x m) m)
- (for-each (lambda (edge)
- (format #t "\t\t\t ~A\t~A\n"
- (edge-type edge) (edge-down edge)))
- (dn-ls m)))
- modules))
- (define (frisk . args)
- (let* ((parsed-opts (getopt-long
- (cons "frisk" args)
- '((upstream (single-char #\u))
- (downstream (single-char #\d))
- (internal (single-char #\i))
- (external (single-char #\x))
- (default-module
- (single-char #\m)
- (value #t)))))
- (=u (option-ref parsed-opts 'upstream #f))
- (=d (option-ref parsed-opts 'downstream #f))
- (=i (option-ref parsed-opts 'internal #f))
- (=x (option-ref parsed-opts 'external #f))
- (files (option-ref parsed-opts '() (list)))
- (report ((make-frisker
- `(default-module
- . ,(option-ref parsed-opts 'default-module
- *default-module*)))
- files))
- (modules (report 'modules))
- (internal (report 'internal))
- (external (report 'external))
- (edges (report 'edges)))
- (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
- (length files) "files"
- (length modules) "modules"
- (length internal) "internal"
- (length external) "external"
- (length edges) "edges")
- ((cond ((and =u =d) dump-updown)
- (=u dump-up)
- (else dump-down))
- (cond ((and =i =x) modules)
- (=i internal)
- (else external)))))
- (define main frisk)
|