doc/list-exports.lisp: Forbid bad slot names in private classes.

[sod] / doc / list-exports.lisp

#! /bin/sh
":"; ### -*-lisp-*-
":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/:; export CL_SOURCE_REGISTRY
":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(sod-exports::main)" -- "$0" "$@" || exit 1

(cl:defpackage #:sod-exports
  (:use #:common-lisp
	#+cmu #:mop
	#+sbcl #:sb-mop))

(cl:in-package #:sod-exports)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (mapc #'asdf:load-system '(:sod :sod-frontend)))

(defun symbolicate (&rest things)
  (intern (apply #'concatenate 'string (mapcar #'string things))))

(defun incomprehensible-form (head tail)
  (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))

(defgeneric form-list-exports (head tail)
  (:method (head tail)
    (declare (ignore head tail))
    nil))

(defmethod form-list-exports ((head (eql 'cl:export)) tail)
  (let ((symbols (car tail)))
    (if (and (consp symbols)
	     (eq (car symbols) 'quote))
	(let ((thing (cadr symbols)))
	  (if (atom thing) (list thing) thing))
	(incomprehensible-form head tail))))

(defmethod form-list-exports ((head (eql 'sod:definst)) tail)
  (destructuring-bind (code (streamvar &key export) args &body body) tail
    (declare (ignore streamvar body))
    (and export
	 (list* (symbolicate code '-inst)
		(symbolicate 'make- code '-inst)
		(labels ((dig (tree path)
			   (if (or (atom tree) (null path)) tree
			       (dig (nth (car path) tree) (cdr path))))
			 (cook (arg)
			   (if (consp arg) (car arg)
			       (let ((name (symbol-name arg)))
				 (if (char= (char name 0) #\%)
				     (intern (subseq name 1))
				     arg))))
			 (instify (arg)
			   (symbolicate 'inst- (cook arg))))
		  (loop with state = :mandatory
			for arg in args
			if (and (symbolp arg)
				(char= (char (symbol-name arg) 0) #\&))
			  do (setf state arg)
			else if (member state '(:mandatory &rest))
			  collect (instify arg)
			else if (member state '(&optional &aux))
			  collect (instify (dig arg '(0)))
			else if (eq state '&key)
			  collect (instify (dig arg '(0 1)))
			else
			  do (error "Confused by ~S." arg)))))))

(defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)
  (destructuring-bind (kind what) tail
    (declare (ignore what))
    (list kind
	  (symbolicate 'c- kind '-type)
	  (symbolicate 'make- kind '-type))))

(defmethod form-list-exports ((head (eql 'sod:defctype)) tail)
  (destructuring-bind (names value &key export) tail
    (declare (ignore value))
    (let ((names (if (listp names) names (list names))))
      (and export
	   (list* (symbolicate 'c-type- (car names)) names)))))

(defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)
  (destructuring-bind (names type &key export) tail
    (declare (ignore type))
    (let ((names (if (listp names) names (list names))))
      (and export
	   (list* (symbolicate 'c-type- (car names)) names)))))

(defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)
  (mapcan #'form-exports (cdr tail)))

(defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
  (mapcan #'form-exports (cdr tail)))

(defmethod form-list-exports ((head (eql 'cl:progn)) tail)
  (mapcan #'form-exports tail))

(defgeneric form-exports (form)
  (:method (form) nil)
  (:method ((form cons)) (form-list-exports (car form) (cdr form))))

(defgeneric list-exports (thing))

(defmethod list-exports ((stream stream))
  (loop with eof = '#:eof
	for form = (read stream nil eof)
	until (eq form eof)
	when (consp form) nconc (form-exports form)))

(defmethod list-exports ((path pathname))
  (mapcar (lambda (each)
	    (cons each (with-open-file (stream each) (list-exports stream))))
	  (directory (merge-pathnames path #p"*.lisp"))))

(defmethod list-exports ((path string))
  (list-exports (pathname path)))

(defun list-exported-symbols (package)
  (sort (loop for s being the external-symbols of package collect s)
	#'string< :key #'symbol-name))

(defun list-all-symbols (package)
  (let ((externs (make-hash-table)))
    (dolist (sym (list-exported-symbols package))
      (setf (gethash sym externs) t))
    (sort (loop for s being the symbols of package
		when (or (not (exported-symbol-p s))
			 (gethash s externs))
		  collect s)
	  #'string< :key #'symbol-name)))

(defun find-symbol-homes (paths package)
  (let* ((symbols (list-exported-symbols package))
	 (exports-alist (let ((*package* package))
			  (mapcan #'list-exports paths)))
	 (homes (make-hash-table :test #'equal)))
    (dolist (assoc exports-alist)
      (let ((home (car assoc)))
	(dolist (symbol (cdr assoc))
	  (let ((name (symbol-name symbol)))
	    (unless (nth-value 1 (find-symbol name package))
	      (format *error-output* ";; unexported: ~S~%" symbol))
	    (setf (gethash name homes) home)))))
    (dolist (symbol symbols)
      (unless (gethash (symbol-name symbol) homes)
	(format *error-output* ";; mysterious: ~S~%" symbol)))
    exports-alist))

(defun boring-setf-expansion-p (symbol)
  (multiple-value-bind (temps args stores store fetch)
      (ignore-errors (get-setf-expansion (list symbol)))
    (declare (ignore temps args stores fetch))
    (and (consp store)
	 (eq (car store) 'funcall)
	 (consp (cdr store)) (consp (cadr store))
	 (eq (caadr store) 'function)
	 (let ((func (cadadr store)))
	   (and (consp func) (consp (cdr func))
		(eq (car func) 'setf))))))

(defun specialized-on-p (func arg what)
  (some (lambda (method)
	  (let ((spec (nth arg (method-specializers method))))
	    (and (typep spec 'eql-specializer)
		 (eql (eql-specializer-object spec) what))))
	(generic-function-methods func)))

(defun categorize (symbol)
  (let ((things nil))
    (when (boundp symbol)
      (push (if (constantp symbol) :constant :variable) things))
    (when (fboundp symbol)
      (push (cond ((macro-function symbol) :macro)
		  ((typep (fdefinition symbol) 'generic-function)
		   :generic)
		  (t :function))
	    things)
      (etypecase (ignore-errors (fdefinition (list 'setf symbol)))
	(generic-function (push :setf-generic things))
	(function (push :setf-function things))
	(null)))
    (when (find-class symbol nil)
      (push :class things))
    (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
	      (specialized-on-p #'sod:expand-c-type-form 0 symbol))
      (push :c-type things))
    (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
	      (specialized-on-p #'sod-parser:expand-parser-form 1 symbol))
      (push :parser things))
    (when (get symbol 'optparse::opthandler)
      (push :opthandler things))
    (when (get symbol 'optparse::optmacro)
      (push :optmacro things))
    (nreverse things)))

(defun categorize-symbols (paths package)
  (mapcar (lambda (assoc)
	    (let ((home (car assoc))
		  (symbols (delete-duplicates
			    (sort (mapcan (lambda (sym)
					    (multiple-value-bind
						(symbol foundp)
						(find-symbol
						 (symbol-name sym)
						 package)
					      (and foundp (list symbol))))
					  (cdr assoc))
				  #'string< :key #'symbol-name))))
	      (cons home (mapcar (lambda (symbol)
				   (cons symbol (categorize symbol)))
				 symbols))))

	  (find-symbol-homes paths package)))

(defun best-package-name (package)

  ;; We pick the shortest one.  Strangely, there's no `find minimal thing
  ;; according to this valuation' function in Common Lisp.
  (loop with best = (package-name package)
	with best-length = (length best)
	for name in (package-nicknames package)
	for name-length = (length name)
	when (< name-length best-length)
	  do (setf best name
		   best-length name-length)
	finally (return best)))

(defvar charbuf-size 0)

(defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
  (and package
       (multiple-value-bind (sym how)
	   (find-symbol (symbol-name symbol) package)
	 (and (eq sym symbol)
	      (eq how :external)))))

(defun downcase-or-escape (name)
  (if (every (lambda (char)
	       (or (upper-case-p char)
		   (digit-char-p char)
		   (member char '(#\% #\+ #\- #\* #\/ #\= #\[ #\] #\?))))
	     name)
      (string-downcase name)
      (with-output-to-string (out)
	(write-char #\| out)
	(map nil (lambda (char)
		   (when (or (char= char #\|)
			     (char= char #\\))
		     (write-char #\\ out))
		   (write-char char out))
	     name)
	(write-char #\| out))))

(defun pretty-symbol-name (symbol package)
  (let ((pkg (symbol-package symbol))
	(exportp (exported-symbol-p symbol)))
    (format nil "~:[~A:~:[:~;~]~;~2*~]~A"
	    (and exportp (eq pkg package))
	    (cond ((keywordp symbol) "")
		  ((eq pkg nil) "#")
		  (t (downcase-or-escape (best-package-name pkg))))
	    (or exportp (null pkg))
	    (downcase-or-escape (symbol-name symbol)))))

(deftype interesting-class ()
  '(or standard-class
       structure-class
       #.(class-name (class-of (find-class 'condition)))))

(defun analyse-classes (package)
  (setf package (find-package package))
  (let ((classes (mapcan (lambda (symbol)
			   (let ((class (find-class symbol nil)))
			     (and class
				  (typep class 'interesting-class)
				  (list class))))
			 (list-exported-symbols package)))
	(subs (make-hash-table)))
    (let ((done (make-hash-table)))
      (labels ((walk-up (class)
		 (unless (gethash class done)
		   (dolist (super (class-direct-superclasses class))
		     (push class (gethash super subs))
		     (walk-up super))
		   (setf (gethash class done) t))))
	(dolist (class classes)
	  (walk-up class))))
    (labels ((walk-down (this super depth)
	       (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
		       (* 2 depth)
		       (pretty-symbol-name (class-name this) package)
		       (mapcar (lambda (class)
				 (pretty-symbol-name (class-name class)
						     package))
			       (remove super
				       (class-direct-superclasses this))))
	       (dolist (sub (sort (copy-list (gethash this subs))
				  #'string< :key #'class-name))
		 (walk-down sub this (1+ depth)))))
      (walk-down (find-class t) nil 0))))

(defmacro deep-compare ((left right) &body body)
  (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
	(l (gensym "LEFT-")) (r (gensym "RIGHT-")))
    `(macrolet ((focus (expr &body body)
		  `(flet ((,',func (it) ,expr))
		     (let ((,',l (,',func ,',l))
			   (,',r (,',func ,',r)))
		       ,@body)))
		(update (expr)
		  `(flet ((,',func (it) ,expr))
		     (psetf ,',l (,',func ,',l)
			    ,',r (,',func ,',r))))
		(compare (expr)
		  `(cond ((let ((left ,',l) (right ,',r)) ,expr)
			  (return-from ,',block t))
			 ((let ((right ,',l) (left ,',r)) ,expr)
			  (return-from ,',block nil))))
		(typesw (&rest clauses)
		  (labels ((iter (clauses)
			     (if (null clauses)
				 'nil
				 (destructuring-bind (type &rest body)
				     (car clauses)
				   (if (eq type t)
				       `(progn ,@body)
				       `(if (typep ,',l ',type)
					    (if (typep ,',r ',type)
						(progn ,@body)
						(return-from ,',block t))
					    (if (typep ,',r ',type)
						(return-from ,',block nil)
						,(iter (cdr clauses)))))))))
		    (iter clauses))))
       (let ((,l ,left) (,r ,right))
	 (block ,block
	   ,@body)))))

(defun order-specializers (la lb)
  (deep-compare (la lb)
    (loop (typesw (null (return nil)))
	  (focus (car it)
	    (typesw (eql-specializer
		     (focus (eql-specializer-object it)
		       (typesw (keyword
				(compare (string< left right)))
			       (symbol
				(focus (package-name (symbol-package it))
				  (compare (string< left right)))
				(compare (string< left right)))
			       (t
				(focus (with-output-to-string (out)
					 (prin1 it out)
					 (write-char #\nul))
				  (compare (string< left right)))))))
		    (class
		     (focus (class-name it)
		       (focus (package-name (symbol-package it))
			 (compare (string< left right)))
		       (compare (string< left right))))
		    (t
		     (error "unexpected things"))))
	  (update (cdr it)))))

(defun analyse-generic-functions (package)
  (setf package (find-package package))
  (flet ((function-name-core (name)
	   (typecase name
	     (symbol (values name t))
	     ((cons (eql setf) t) (values (cadr name) t))
	     (t (values nil nil)))))
    (let ((methods (make-hash-table))
	  (functions (make-hash-table))
	  (externs (make-hash-table)))
      (dolist (symbol (list-exported-symbols package))
	(setf (gethash symbol externs) t))
      (dolist (symbol (list-exported-symbols package))
	(flet ((dofunc (func)
		 (when (typep func 'generic-function)
		   (setf (gethash func functions) t)
		   (dolist (method (generic-function-methods func))
		     (setf (gethash method methods) t)))))
	  (dofunc (and (fboundp symbol) (fdefinition symbol)))
	  (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
	(when (eq (symbol-package symbol) package)
	  (let ((class (find-class symbol nil)))
	    (when class
	      (dolist
		  (func (specializer-direct-generic-functions class))
		(multiple-value-bind (name knownp)
		    (function-name-core (generic-function-name func))
		  (when (and knownp
			     (or (not (eq (symbol-package name) package))
				 (gethash name externs)))
		    (setf (gethash func functions) t)
		    (dolist (method (specializer-direct-methods class))
		      (setf (gethash method methods) t)))))))))
      (let ((funclist nil))
	(maphash (lambda (func value)
		   (declare (ignore value))
		   (push func funclist))
		 functions)
	(setf funclist (sort funclist
			     (lambda (a b)
			       (let ((core-a (function-name-core a))
				     (core-b (function-name-core b)))
				 (if (eq core-a core-b)
				     (and (atom a) (consp b))
				     (string< core-a core-b))))
			     :key #'generic-function-name))
	(dolist (function funclist)
	  (let ((name (generic-function-name function)))
	    (etypecase name
	      (symbol
	       (format t "~A~%" (pretty-symbol-name name package)))
	      ((cons (eql setf) t)
	       (format t "(setf ~A)~%"
		       (pretty-symbol-name (cadr name) package)))))
	  (dolist (method (sort (copy-list
				 (generic-function-methods function))
				#'order-specializers
				:key #'method-specializers))
	    (when (gethash method methods)
	      (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
		      (mapcar
		       (lambda (spec)
			 (etypecase spec
			   (class
			    (let ((name (class-name spec)))
			      (if (eq name t) "t"
				  (pretty-symbol-name name package))))
			   (eql-specializer
			    (let ((obj (eql-specializer-object spec)))
			      (format nil "(eql ~A)"
				      (if (symbolp obj)
					  (pretty-symbol-name obj package)
					  obj))))))
		       (method-specializers method))
		      (method-qualifiers method)))))))))

(defun check-slot-names (package)
  (setf package (find-package package))
  (let* ((symbols (list-all-symbols package))
	 (classes (mapcan (lambda (symbol)
			    (when (eq (symbol-package symbol) package)
			      (let ((class (find-class symbol nil)))
				(and class (list class)))))
			  symbols))
	 (offenders (mapcan
		     (lambda (class)
		       (let* ((slot-names
			       (mapcar #'slot-definition-name
				       (class-direct-slots class)))
			      (exported (remove-if
					 (lambda (sym)
					   (or (not (symbol-package sym))
					       (and (not (exported-symbol-p
							  sym))
						    (eq (symbol-package sym)
							package))))
					 slot-names)))
			 (and exported
			      (list (cons (class-name class)
					  exported)))))
			    classes))
	 (bad-words (remove-duplicates (mapcan (lambda (list)
						 (copy-list (cdr list)))
					       offenders))))
    (values offenders bad-words)))

(defun report-symbols (paths package)
  (setf package (find-package package))
  (format t "~A~%Package `~(~A~)'~2%"
	  (make-string 77 :initial-element #\-)
	  (package-name package))
  (dolist (assoc (sort (categorize-symbols paths package) #'string<
		       :key (lambda (assoc)
			      (file-namestring (car assoc)))))
    (when (cdr assoc)
      (format t "~A~%" (file-namestring (car assoc)))
      (dolist (def (cdr assoc))
	(let ((sym (car def)))
	  (format t "  ~A~@[~48T~{~(~A~)~^ ~}~]~%"
		  (pretty-symbol-name sym package)
		  (cdr def))))
      (terpri)))
  (multiple-value-bind (alist names) (check-slot-names package)
    (when names
      (format t "Leaked slot names: ~{~A~^, ~}~%"
	      (mapcar (lambda (name) (pretty-symbol-name name package))
		      names))
      (dolist (assoc alist)
	(format t "~2T~A: ~{~A~^, ~}~%"
		(pretty-symbol-name (car assoc) package)
		(mapcar (lambda (name) (pretty-symbol-name name package))
			(cdr assoc))))
      (terpri)))
  (format t "Classes:~%")
  (analyse-classes package)
  (terpri)
  (format t "Methods:~%")
  (analyse-generic-functions package)
  (terpri))

(export 'report-project-symbols)
(defun report-project-symbols ()
  (labels ((components (comp)
	     (asdf:component-children comp))
	   (files (comp)
	     (sort (remove-if-not (lambda (comp)
				    (typep comp 'asdf:cl-source-file))
				  (components comp))
		   #'string< :key #'asdf:component-name))
	   (by-name (comp name)
	     (gethash name (asdf:component-children-by-name comp)))
	   (file-name (file)
	     (slot-value file 'asdf/component:absolute-pathname)))
  (let* ((sod (asdf:find-system "sod"))
	 (parser-files (files (by-name sod "parser")))
	 (utilities (by-name sod "utilities"))
	 (sod-frontend (asdf:find-system "sod-frontend"))
	 (optparse (by-name sod "optparse"))
	 (frontend (by-name sod-frontend "frontend"))
	 (sod-files (set-difference (files sod) (list optparse utilities))))
    (report-symbols (mapcar #'file-name sod-files) "SOD")
    (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND")
    (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
    (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE")
    (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))

(defun main ()
  (with-open-file (*standard-output* #p"doc/SYMBOLS"
		   :direction :output
		   :if-exists :supersede
		   :if-does-not-exist :create)
    (report-project-symbols)))

#+interactive (main)