guile18/scripts/frisk

   1 #!/bin/sh
   2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
   3 main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')'
   4 exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
   5 !#
   6 ;;; frisk --- Grok the module interfaces of a body of files
   7
   8 ;;      Copyright (C) 2002, 2006 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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301 USA
  24
  25 ;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
  26
  27 ;;; Commentary:
  28
  29 ;; Usage: frisk [options] file ...
  30 ;;
  31 ;; Analyze FILE... module interfaces in aggregate (as a "body"),
  32 ;; and display a summary.  Modules that are `define-module'd are
  33 ;; considered "internal" (and those not, "external").  When module X
  34 ;; uses module Y, X is said to be "(a) downstream of" Y, and Y is
  35 ;; "(an) upstream of" X.
  36 ;;
  37 ;; Normally, the summary displays external modules and their internal
  38 ;; downstreams, as this is the usual question asked by a body.  There
  39 ;; are several options that modify this output.
  40 ;;
  41 ;;  -u, --upstream      show upstream edges
  42 ;;  -d, --downstream    show downstream edges (default)
  43 ;;  -i, --internal      show internal modules
  44 ;;  -x, --external      show external modules (default)
  45 ;;
  46 ;; If given both `upstream' and `downstream' options ("frisk -ud"), the
  47 ;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is
  48 ;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE
  49 ;; MODULE-NAME ...).
  50 ;;
  51 ;; In all other cases, the "C MODULE" occupies its own line, and
  52 ;; subsequent lines list the up- or downstream edges, respectively,
  53 ;; indented by some non-zero amount of whitespace.
  54 ;;
  55 ;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a
  56 ;; file that do not follow a `define-module' result an edge where the
  57 ;; downstream is the "default module", normally `(guile-user)'.  This
  58 ;; can be set to another value by using:
  59 ;;
  60 ;;  -m, --default-module MOD    set MOD as the default module
  61
  62 ;; Usage from a Scheme Program: (use-modules (scripts frisk))
  63 ;;
  64 ;; Module export list:
  65 ;;  (frisk . args)
  66 ;;  (make-frisker . options)    => (lambda (files) ...) [see below]
  67 ;;  (mod-up-ls module)          => upstream edges
  68 ;;  (mod-down-ls module)        => downstream edges
  69 ;;  (mod-int? module)           => is the module internal?
  70 ;;  (edge-type edge)            => symbol: {regular,autoload,computed}
  71 ;;  (edge-up edge)              => upstream module
  72 ;;  (edge-down edge)            => downstream module
  73 ;;
  74 ;; OPTIONS is an alist.  Recognized keys are:
  75 ;;  default-module
  76 ;;
  77 ;; `make-frisker' returns a procedure that takes a list of files, the
  78 ;; FRISKER.  FRISKER returns a closure, REPORT, that takes one of the
  79 ;; keys:
  80 ;;  modules  -- entire list of modules
  81 ;;  internal -- list of internal modules
  82 ;;  external -- list of external modules
  83 ;;  i-up     -- list of modules upstream of internal modules
  84 ;;  x-up     -- list of modules upstream of external modules
  85 ;;  i-down   -- list of modules downstream of internal modules
  86 ;;  x-down   -- list of modules downstream of external modules
  87 ;;  edges    -- list of edges
  88 ;; Note that `x-up' should always be null, since by (lack of!)
  89 ;; definition, we only know external modules by reference.
  90 ;;
  91 ;; The module and edge objects managed by REPORT can be examined in
  92 ;; detail by using the other (self-explanatory) procedures.  Be careful
  93 ;; not to confuse a freshly consed list of symbols, like `(a b c)' with
  94 ;; the module `(a b c)'.  If you want to find the module by that name,
  95 ;; try: (cond ((member '(a b c) (REPORT 'modules)) => car)).
  96
  97 ;; TODO: Make "frisk -ud" output less ugly.
  98 ;;       Consider default module as internal; add option to invert.
  99 ;;       Support `edge-misc' data.
 100
 101 ;;; Code:
 102
 103 (define-module (scripts frisk)
 104   :autoload (ice-9 getopt-long) (getopt-long)
 105   :use-module ((srfi srfi-1) :select (filter remove))
 106   :export (frisk
 107            make-frisker
 108            mod-up-ls mod-down-ls mod-int?
 109            edge-type edge-up edge-down))
 110
 111 (define *default-module* '(guile-user))
 112
 113 (define (grok-proc default-module note-use!)
 114   (lambda (filename)
 115     (let* ((p (open-file filename "r"))
 116            (next (lambda () (read p)))
 117            (ferret (lambda (use)   ;;; handle "((foo bar) :select ...)"
 118                      (let ((maybe (car use)))
 119                        (if (list? maybe)
 120                            maybe
 121                            use))))
 122            (curmod #f))
 123       (let loop ((form (next)))
 124         (cond ((eof-object? form))
 125               ((not (list? form)) (loop (next)))
 126               (else (case (car form)
 127                       ((define-module)
 128                        (let ((module (cadr form)))
 129                          (set! curmod module)
 130                          (note-use! 'def module #f)
 131                          (let loop ((ls form))
 132                            (or (null? ls)
 133                                (case (car ls)
 134                                  ((:use-module)
 135                                   (note-use! 'regular module (ferret (cadr ls)))
 136                                   (loop (cddr ls)))
 137                                  ((:autoload)
 138                                   (note-use! 'autoload module (cadr ls))
 139                                   (loop (cdddr ls)))
 140                                  (else (loop (cdr ls))))))))
 141                       ((use-modules)
 142                        (for-each (lambda (use)
 143                                    (note-use! 'regular
 144                                               (or curmod default-module)
 145                                               (ferret use)))
 146                                  (cdr form)))
 147                       ((load primitive-load)
 148                        (note-use! 'computed
 149                                   (or curmod default-module)
 150                                   (let ((file (cadr form)))
 151                                     (if (string? file)
 152                                         file
 153                                         (format #f "[computed in ~A]"
 154                                                 filename))))))
 155                     (loop (next))))))))
 156
 157 (define up-ls (make-object-property))   ; list
 158 (define dn-ls (make-object-property))   ; list
 159 (define int?  (make-object-property))   ; defined via `define-module'
 160
 161 (define mod-up-ls up-ls)
 162 (define mod-down-ls dn-ls)
 163 (define mod-int? int?)
 164
 165 (define (i-or-x module)
 166   (if (int? module) 'i 'x))
 167
 168 (define edge-type (make-object-property)) ; symbol
 169
 170 (define (make-edge type up down)
 171   (let ((new (cons up down)))
 172     (set! (edge-type new) type)
 173     new))
 174
 175 (define edge-up car)
 176 (define edge-down cdr)
 177
 178 (define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
 179 (define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
 180
 181 (define (make-body alist)
 182   (lambda (key)
 183     (assq-ref alist key)))
 184
 185 (define (scan default-module files)
 186   (let* ((modules (list))
 187          (edges (list))
 188          (intern (lambda (module)
 189                    (cond ((member module modules) => car)
 190                          (else (set! (up-ls module) (list))
 191                                (set! (dn-ls module) (list))
 192                                (set! modules (cons module modules))
 193                                module))))
 194          (grok (grok-proc default-module
 195                           (lambda (type d u)
 196                             (let ((d (intern d)))
 197                               (if (eq? type 'def)
 198                                   (set! (int? d) #t)
 199                                   (let* ((u (intern u))
 200                                          (edge (make-edge type u d)))
 201                                     (set! edges (cons edge edges))
 202                                     (up-ls+! d edge)
 203                                     (dn-ls+! u edge))))))))
 204     (for-each grok files)
 205     (make-body
 206      `((modules  . ,modules)
 207        (internal . ,(filter int? modules))
 208        (external . ,(remove int? modules))
 209        (i-up     . ,(filter int? (map edge-down edges)))
 210        (x-up     . ,(remove int? (map edge-down edges)))
 211        (i-down   . ,(filter int? (map edge-up   edges)))
 212        (x-down   . ,(remove int? (map edge-up   edges)))
 213        (edges    . ,edges)))))
 214
 215 (define (make-frisker . options)
 216   (let ((default-module (or (assq-ref options 'default-module)
 217                             *default-module*)))
 218     (lambda (files)
 219       (scan default-module files))))
 220
 221 (define (dump-updown modules)
 222   (for-each (lambda (m)
 223               (format #t "~A ~A --- ~A --- ~A\n"
 224                       (i-or-x m) m
 225                       (map (lambda (edge)
 226                              (cons (edge-type edge)
 227                                    (edge-up edge)))
 228                            (up-ls m))
 229                       (map (lambda (edge)
 230                              (cons (edge-type edge)
 231                                    (edge-down edge)))
 232                            (dn-ls m))))
 233             modules))
 234
 235 (define (dump-up modules)
 236   (for-each (lambda (m)
 237               (format #t "~A ~A\n" (i-or-x m) m)
 238               (for-each (lambda (edge)
 239                           (format #t "\t\t\t ~A\t~A\n"
 240                                   (edge-type edge) (edge-up edge)))
 241                         (up-ls m)))
 242             modules))
 243
 244 (define (dump-down modules)
 245   (for-each (lambda (m)
 246               (format #t "~A ~A\n" (i-or-x m) m)
 247               (for-each (lambda (edge)
 248                           (format #t "\t\t\t ~A\t~A\n"
 249                                   (edge-type edge) (edge-down edge)))
 250                         (dn-ls m)))
 251             modules))
 252
 253 (define (frisk . args)
 254   (let* ((parsed-opts (getopt-long
 255                        (cons "frisk" args)    ;;; kludge
 256                        '((upstream (single-char #\u))
 257                          (downstream (single-char #\d))
 258                          (internal (single-char #\i))
 259                          (external (single-char #\x))
 260                          (default-module
 261                            (single-char #\m)
 262                            (value #t)))))
 263          (=u (option-ref parsed-opts 'upstream #f))
 264          (=d (option-ref parsed-opts 'downstream #f))
 265          (=i (option-ref parsed-opts 'internal #f))
 266          (=x (option-ref parsed-opts 'external #f))
 267          (files    (option-ref parsed-opts '() (list)))
 268          (report   ((make-frisker
 269                      `(default-module
 270                         . ,(option-ref parsed-opts 'default-module
 271                                        *default-module*)))
 272                     files))
 273          (modules  (report 'modules))
 274          (internal (report 'internal))
 275          (external (report 'external))
 276          (edges    (report 'edges)))
 277     (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
 278             (length files)    "files"
 279             (length modules)  "modules"
 280             (length internal) "internal"
 281             (length external) "external"
 282             (length edges)    "edges")
 283     ((cond ((and =u =d) dump-updown)
 284            (=u dump-up)
 285            (else dump-down))
 286      (cond ((and =i =x) modules)
 287            (=i internal)
 288            (else external)))))
 289
 290 (define main frisk)
 291
 292 ;;; frisk ends here