;"vet.scm" Check exports, references, and documentation of library modules.
;Copyright (C) 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;@code{(require 'vet)}
;;@ftindex vet
(require 'common-list-functions)
(require 'top-refs)
(require 'manifest)
(define r4rs-symbols
'(* + - -> / < <= = => > >= ... abs acos and angle append apply asin
assoc assq assv atan begin boolean? caaaar caaadr caaar caadar
caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
call-with-current-continuation call-with-input-file
call-with-output-file car case cdaaar cdaadr cdaar cdadar cdaddr
cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr
ceiling char->integer char-alphabetic? char-ci<=? char-ci<?
char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case?
char-numeric? char-ready? char-upcase char-upper-case?
char-whitespace? char<=? char<? char=? char>=? char>? char?
close-input-port close-output-port complex? cond cons cos
current-input-port current-output-port define display do else
eof-object? eq? equal? eqv? even? exact->inexact exact? exp expt
floor for-each gcd if imag-part implementation-vicinity
in-vicinity inexact->exact inexact? input-port? integer->char
integer? lambda lcm length let let* letrec library-vicinity list
list-ref list->string list->vector list? load log magnitude
make-polar make-rectangular make-string make-vector
make-vicinity map max member memq memv min modulo negative?
newline not null? number->string number? odd? open-input-file
open-output-file or output-port? pair? peek-char positive?
procedure? quasiquote quotient rational? read read-char
real-part real? remainder reverse round set! set-car! set-cdr!
sin sqrt string string->list string->number string->symbol
string-append string-ci<=? string-ci<? string-ci=? string-ci>=?
string-ci>? string-length string-ref string-set! string<=?
string<? string=? string>=? string>? string? sub-vicinity
substring symbol->string symbol? tan truncate unquote
unquote-splicing user-vicinity vector vector->list vector-length
vector-ref vector-set! vector? write write-char zero? ))
(define (path<-entry entry)
(define (findit path)
(cond ((not (string? path)) #f)
((file-exists? path) path)
((file-exists? (string-append path ".scm"))
(string-append path ".scm"))
(else #f)))
(cond ((string? (cdr entry)) (findit (cdr entry)))
((not (pair? (cdr entry))) #f)
(else (case (cadr entry)
((source defmacro macro syntactic-closures
syntax-case macros-that-work)
(let ((lp (last-pair entry)))
(or (and (string? (car lp)) (findit (car lp)))
(and (string? (cdr lp)) (findit (cdr lp))))))
(else #f)))))
(define slib:catalog (cdr (member (assq 'null *catalog*) *catalog*)))
(define (top-refs<-files filenames)
(remove-duplicates (apply append (map top-refs<-file filenames))))
(define (provided+? . features)
(lambda (feature)
(or (memq feature features) (provided? feature))))
(define (requires<-file filename)
(file->requires filename (provided+? 'compiling) slib:catalog))
(define (requires<-files filenames)
(remove-duplicates (apply append (map requires<-file filenames))))
(define (definitions<-files filenames)
(remove-duplicates (apply append (map file->definitions filenames))))
(define (exports<-files filenames)
(remove-duplicates (apply append (map file->exports filenames))))
(define (code-walk-justify lst . margins)
(define left-margin (case (length margins)
((1 2 3) (car margins))
((0) 0)
(else (slib:error 'code-walk-justify 'wna margins))))
(define right-margin (case (length margins)
((2 3) (cadr margins))
(else (output-port-width))))
(define spacer (case (length margins)
((3) (caddr margins))
(else #\space)))
(cond ((>= left-margin right-margin)
(slib:error 'code-walk-justify
" left margin must be smaller than right: "
margins)))
(let ((cur left-margin)
(lms (make-string left-margin #\space)))
(display lms)
(for-each
(lambda (obj)
(if (symbol? obj) (set! obj (symbol->string obj)))
(let ((objl (string-length obj)))
(cond ((= left-margin cur)
(display obj)
(set! cur (+ objl cur)))
((<= right-margin (+ 1 objl cur))
(newline)
(set! cur (+ objl left-margin))
(display lms) (display obj))
(else
(display #\space)
(display obj)
(set! cur (+ 1 objl cur))))))
lst)))
;;@args file1 @dots{}
;;Using the procedures in the @code{top-refs} and @code{manifest}
;;modules, @0 analyzes each SLIB module and @1, @dots{}, reporting
;;about any procedure or macro defined whether it is:
;;
;;@table @asis
;;
;;@item orphaned
;;defined, not called, not exported;
;;@item missing
;;called, not defined, and not exported by its @code{require}d modules;
;;@item undocumented-export
;;Exported by module, but no index entry in @file{slib.info};
;;
;;@end table
;;
;;And for the library as a whole:
;;
;;@table @asis
;;
;;@item documented-unexport
;;Index entry in @file{slib.info}, but no module exports it.
;;
;;@end table
;;
;;This straightforward analysis caught three full days worth of
;;never-executed branches, transitive require assumptions, spelling
;;errors, undocumented procedures, missing procedures, and cyclic
;;dependencies in SLIB.
;;
;;The optional arguments @1, @dots{} provide a simple way to vet
;;prospective SLIB modules.
(define (vet-slib . files)
(define infos
(exports<-info-index (in-vicinity (library-vicinity) "slib.info") 1 2))
(define r4rs+slib #f)
(define export-alist '())
(define all-exports '())
(define slib-exports
(union '(system getenv current-time difftime offset-time)
(union (file->exports
(in-vicinity (library-vicinity) "Template.scm"))
(file->exports
(in-vicinity (library-vicinity) "require.scm")))))
(define (show lst name)
(cond ((not (null? lst))
(display " ") (display name) (display ":") (newline)
(code-walk-justify lst 10)
(newline))))
(define (dopath path)
(define paths (cons path (file->loads path)))
(let ((requires (requires<-files paths))
(defines (definitions<-files paths))
(exports (exports<-files paths))
(top-refs (top-refs<-files paths)))
(define orphans (set-difference (set-difference defines exports)
top-refs))
(define missings (set-difference
(set-difference top-refs defines)
r4rs+slib))
(set! all-exports (union exports all-exports))
(for-each (lambda (req)
(define pr (assq req export-alist))
(and pr (set! missings (set-difference missings (cdr pr)))))
requires)
(let ((undocs (set-difference exports (union r4rs-symbols infos))))
(cond ((not (every null? (list undocs orphans missings)))
(write paths) (newline)
;;(show requires 'requires)
;;(show defines 'defines)
;;(show exports 'exports)
(show undocs 'undocumented-exports)
(show orphans 'orphans)
(show missings 'missing)
)))))
(set! r4rs+slib (union r4rs-symbols slib-exports))
(let ((catalog
(append (map (lambda (file) (cons (string->symbol file) file))
files)
slib:catalog)))
(for-each (lambda (entry)
(set! export-alist
(cons (cons (car entry)
(feature->exports (car entry) slib:catalog))
export-alist)))
catalog)
(for-each (lambda (entry)
(define path (path<-entry entry))
(and path (dopath path)))
catalog))
(write '("SLIB"))
(show (set-difference infos (union r4rs+slib all-exports))
'documented-unexports))