scripts/frisk peek (wip)

[Thien-Thi Nguyen]

hello everyone,

currently writing "scripts/frisk", work-in-progress source appended
below.  here is a sample run:

  cd /home/ttn/build/.gnu/guile-core/scripts/
  ./frisk ../srfi/*.scm
  13 files, 13 modules defined, 18 modules referenced
  5 external, 6 internal whose upstream is external
  
  x (ice-9 and-let-star)
                           regular        (srfi srfi-2)
  x (ice-9 syncase)
                           regular        (srfi srfi-11)
  x (ice-9 rdelim)
                           regular        (srfi srfi-10)
  x (ice-9 receive)
                           regular        (srfi srfi-8)
                           regular        (srfi srfi-1)
  x (ice-9 session)
                           regular        (srfi srfi-1)
  
  Compilation finished at Sun Jan  6 16:07:44

to play, try invoking w/ one or more of the following env vars set:
ALL, INT, UP, UPDOWN.  (in final form, the script will take regular
"--options" instead of env vars, which will go away.)

happy hacking,
thi

_________________________________________
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; frisk --- Grok the module interfaces of a body of files

;;      Copyright (C) 2001 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA

;;; Author: Thien-Thi Nguyen <address@hidden>

;;; Commentary:

;; Usage: frisk FILE ...
;;
;; Analyze FILE... module interfaces in aggregate (as a "body"),
;; and display a summary.  Modules that are `define-module'd are
;; considered "internal" (and those not, "external").  When module X
;; uses module Y, X is said to be "downstream of" Y, and Y is
;; "upstream of" X.
;;
;; [todo]
;;
;; Module export list:
;;  (frisk . files)
;;  (frisk-silently . files)

;;; Code:

(debug-enable 'backtrace 'debug)        ; here.

(define-module (scripts frisk)
  :use-module ((srfi srfi-1) :select (filter remove fold))
  :export (frisk frisk-silently))

(define default-module '(guile-user))

(define (grok filename note-use!)
  (let* ((p (open-file filename "r"))
         (next (lambda () (read p)))
         (ferret (lambda (use)   ;;; handle "((foo bar) :select ...)"
                   (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)
                                (note-use! 'regular module (ferret (cadr ls)))
                                (loop (cddr ls)))
                               ((: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 uses (make-object-property))    ; list
(define used (make-object-property))    ; list
(define def? (make-object-property))    ; defined via `define-module'

(define (dump ls)
  (for-each (lambda (z)
              (format #t "~A ~A --- ~A --- ~A\n"
                      (if (def? z) 'i 'x) z (uses z) (used z)))
            ls))

(define (dump-up ls)
  (for-each (lambda (z)
              (format #t "~A ~A\n" (if (def? z) 'i 'x) z)
              (for-each (lambda (d)
                          (format #t "\t\t\t ~A\t~A\n"
                                  (car d) (cdr d)))
                        (uses z)))
            ls))

(define (dump-down ls)
  (for-each (lambda (z)
              (format #t "~A ~A\n" (if (def? z) 'i 'x) z)
              (for-each (lambda (d)
                          (format #t "\t\t\t ~A\t~A\n"
                                  (car d) (cdr d)))
                        (used z)))
            ls))

(define (make-body all)
  (let* ((internal  (filter def? all))
         (external  (remove def? all))
         (up        (filter uses all))
         (down      (filter used all))
         (i-up-is-x (fold (lambda (i so-far)
                            (append so-far
                                    (remove def? (map cdr (uses i)))))
                          (list)
                          internal)))
    (lambda (choice)                    ; closure
      (case choice
        ;; data
        ((all)       all)
        ((internal)  internal)
        ((external)  external)
        ((up)        up)
        ((down)      down)
        ((i-up-is-x) i-up-is-x)))))

(define (frisk-silently . files)
  (let* ((all (list))
         (intern (lambda (module)
                   (cond ((member module all) => car)
                         (else (set! (uses module) (list))
                               (set! (used module) (list))
                               (set! all (cons module all))
                               module))))
         (use! (lambda (type module use)
                 (let ((module (intern module))
                       (use (and use (intern use)))) ; ugh
                   (if (eq? type 'def)
                       (begin
                         (set! (def? module) #t))
                       (begin
                         (set! (uses module)
                               (cons (cons type use)
                                     (uses module)))
                         (set! (used use)
                               (cons (cons type module)
                                     (used use))))))))
         (scan (lambda (file)
                 (grok file use!))))
    (for-each scan files)
    (make-body all)))

(define (frisk . files)
  (let* ((body (apply frisk-silently files))
         (all (body 'all))
         (internal (body 'internal))
         (external (body 'external))
         (i-up-is-x (body 'i-up-is-x)))
    (format #t "~A ~A, ~A ~A, ~A ~A\n~A ~A, ~A ~A\n\n"
            (length files)     "files"
            (length internal)  "modules defined"
            (length all)       "modules referenced"
            (length external)  "external"
            (length i-up-is-x) "internal whose upstream is external")
    ((cond ((getenv "UP") dump-up)              ;;; env vars temporary
           ((getenv "UPDOWN") dump)
           (else dump-down))
     (cond ((getenv "ALL") all)
           ((getenv "INT") internal)
           (else external)))))

(define main frisk)

;;; frisk ends here