;"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))