#!/usr/bin/guile \
-e "(scripts frisk)" -s
!#
;;; frisk --- Grok the module interfaces of a body of files

;; 	Copyright (C) 2002,2003,2004,2005 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: frisk [options] 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 "(a) downstream of" Y, and Y is
;; "(an) upstream of" X.
;;
;; Normally, the summary displays external modules and their internal
;; downstreams, as this is the usual question asked by a body.  There
;; are several options that modify this output.
;;
;;  -u, --upstream      show upstream edges
;;  -d, --downstream    show downstream edges (default)
;;  -i, --internal      show internal modules
;;  -x, --external      show external modules (default)
;;
;; If given both `upstream' and `downstream' options ("frisk -ud"), the
;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is
;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE
;; MODULE-NAME ...).
;;
;; In all other cases, the "C MODULE" occupies its own line, and
;; subsequent lines list the up- or downstream edges, respectively,
;; indented by some non-zero amount of whitespace.
;;
;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a
;; file that do not follow a `define-module' result in an edge where the
;; downstream is the "default module", normally `(guile-user)'.  This
;; can be set to another value by using:
;;
;;  -m, --default-module MOD    set MOD as the default module

;; Usage from a Scheme Program: (use-modules (scripts frisk))
;;
;; Module export list:
;;  (make-frisker . options)    => (lambda (files) ...) [see below]
;;  (mod-up-ls module)          => upstream edges
;;  (mod-down-ls module)        => downstream edges
;;  (mod-int? module)           => is the module internal?
;;  (edge-type edge)            => symbol: {regular,autoload,computed}
;;  (edge-up edge)              => upstream module
;;  (edge-down edge)            => downstream module
;;
;; OPTIONS is an alist.  Recognized keys are:
;;  default-module
;;
;; `make-frisker' returns a procedure that takes a list of files, the
;; FRISKER.  FRISKER returns a closure, REPORT, that takes one of the
;; keywords (symbols also ok):
;;  #:modules  -- entire list of modules
;;  #:internal -- list of internal modules
;;  #:external -- list of external modules
;;  #:i-up     -- list of modules upstream of internal modules
;;  #:x-up     -- list of modules upstream of external modules
;;  #:i-down   -- list of modules downstream of internal modules
;;  #:x-down   -- list of modules downstream of external modules
;;  #:edges    -- list of edges
;; Note that #:x-up will always return the empty list, since by (lack of!)
;; definition, we only know external modules by reference.
;;
;; The module and edge objects managed by REPORT can be examined in
;; detail by using the other (self-explanatory) procedures.  Be careful
;; not to confuse a freshly consed list of symbols, like `(a b c)' with
;; the module `(a b c)'.  If you want to find the module by that name,
;; do something like: (and=> (member '(a b c) (REPORT #:modules)) car).

;; TODO: Make "frisk -ud" output less ugly.
;;       Consider default module as internal; add option to invert.

;;; Code:

(define-module (scripts frisk)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload (scripts scan-md-module) (scan-md-module-file)
  ;; bring this back when we can autoload and select at the same time
  ;;  #:use-module ((srfi srfi-1) :select (filter remove))
  #:autoload (srfi srfi-1) (filter remove)
  #:export (make-frisker
            mod-up-ls mod-down-ls mod-int?
            edge-type edge-up edge-down))

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

(define (fln s . args)
  (apply simple-format #t s args)
  (newline))

(define (grok-proc default-module note-use!)
  (lambda (filename)
    (let* ((p (open-input-file filename))
           (first? #t)
           (next (lambda () (false-if-exception (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) (close-port p))
              ((or (and first? (symbol? form))
                   (begin (set! first? #f) #f))
               (close-port p)
               (let* ((ans (scan-md-module-file filename))
                      ;; (MODULE-NAME scm_init_module LINK-FUNC USES ...)
                      ;;  where MODULE-NAME can be #f if unrecognized.
                      (module (car ans))
                      (uses (or (and module
                                     ;; handle incomplete/old-style entries
                                     (pair? (cdddr ans))
                                     (cadddr ans))
                                '())))
                 (and module (note-use! 'def module #f))
                 (for-each (lambda (use)
                             (note-use! 'regular module use))
                           uses)))
              ((not (pair? 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
                                        (simple-format #f "[computed in ~A]"
                                                       filename))))))
                    (loop (next))))))))

(define up-ls (make-object-property))   ; list
(define dn-ls (make-object-property))   ; list
(define int?  (make-object-property))   ; defined via `define-module'

(define (mod-up-ls   m) (up-ls m))      ; read-only
(define (mod-down-ls m) (dn-ls m))
(define (mod-int?    m) (int?  m))

(define (i-or-x module)
  (if (int? module) 'i 'x))

(define etype (make-object-property))   ; symbol

(define (edge-type e) (etype e))        ; read-only

(define (make-edge type up down)
  (let ((new (cons up down)))
    (set! (etype new) type)
    new))

(define (edge-up   edge) (car edge))
(define (edge-down edge) (cdr edge))

(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 (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)
    (let ((details `((#: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))))
      ;; rv
      (lambda (key)
        (assq-ref details (if (symbol? key)
                              (symbol->keyword key)
                              key))))))

(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)
              (fln "~A ~A --- ~A --- ~A"
                   (i-or-x m) m
                   (map (lambda (edge)
                          (cons (etype edge)
                                (edge-up edge)))
                        (up-ls m))
                   (map (lambda (edge)
                          (cons (etype edge)
                                (edge-down edge)))
                        (dn-ls m))))
            modules))

(define (dump-up modules)
  (for-each (lambda (m)
              (fln "~A ~A" (i-or-x m) m)
              (for-each (lambda (edge)
                          (fln "\t\t\t ~A\t~A"
                               (etype edge) (edge-up edge)))
                        (up-ls m)))
            modules))

(define (dump-down modules)
  (for-each (lambda (m)
              (fln "~A ~A" (i-or-x m) m)
              (for-each (lambda (edge)
                          (fln "\t\t\t ~A\t~A"
                               (etype edge) (edge-down edge)))
                        (dn-ls m)))
            modules))

(define (frisk/qop qop)
  (let* ((=u (qop 'upstream))
         (=d (qop 'downstream))
         (=i (qop 'internal))
         (=x (qop 'external))
         (files    (or (qop '()) (list)))
         (report   ((make-frisker
                     `(default-module
                        . ,(or (qop 'default-module) *default-module*)))
                    files))
         (modules  (report #:modules))
         (internal (report #:internal))
         (external (report #:external))
         (edges    (report #:edges)))
    (fln "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\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 args)
  (HVQC-MAIN args frisk/qop
             '(usage . commentary)
             '(package . "Guile")
             '(option-spec (upstream       (single-char #\u))
                           (downstream     (single-char #\d))
                           (internal       (single-char #\i))
                           (external       (single-char #\x))
                           (default-module (single-char #\m)
                                           (value #t)))))

;;; frisk ends here
