Revision: 4296 Author: edi URL: http://bknr.net/trac/changeset/4296

Not for release

D trunk/thirdparty/hunchentoot/doc/check-doc.lisp

Deleted: trunk/thirdparty/hunchentoot/doc/check-doc.lisp =================================================================== --- trunk/thirdparty/hunchentoot/doc/check-doc.lisp 2009-02-19 01:20:33 UTC (rev 4295) +++ trunk/thirdparty/hunchentoot/doc/check-doc.lisp 2009-02-19 01:29:37 UTC (rev 4296) @@ -1,129 +0,0 @@ - -(defun do-documented-names% (thunk) - (labels ((find-documentation (node) - (when (listp node) - (let* ((symbol-type (cxml-xmls:node-name node)) - (symbol-name (cadr (assoc "name" (cxml-xmls:node-attrs node) :test #'equal))) - (symbol-name (and symbol-name (string-upcase symbol-name)))) - (when (find symbol-type '("function" "reader" "accessor" "constant" "special-variable" "symbol") - :test #'equal) - (funcall thunk symbol-name symbol-type node)) - (mapc #'find-documentation (cxml-xmls:node-children node)))))) - (find-documentation (cxml:parse-file "index.xml" (cxml-xmls:make-xmls-builder)))) - nil) - -(defmacro do-documented-names ((symbol-name-var - &optional - (symbol-type-var (gensym) symbol-type-var-p) - (node-var (gensym) node-var-p)) - &body body) - `(do-documented-names% (lambda (,symbol-name-var ,symbol-type-var ,node-var) - (declare (ignorable - ,(unless symbol-type-var-p - `,symbol-type-var) - ,(unless node-var-p - `,node-var))) - (block nil - ,@body)))) - -(defun documented-names () - "Returns a list of strings, the symbols that are documented in index.xml" - (let (names) - (do-documented-names (symbol-name) - (pushnew symbol-name names :test #'string-equal)) - names)) - -(defun arglist-from-xml-lambda-list (nodes) - (format nil "(~:@(~A~))" - (string-trim " " - (apply #'concatenate 'string - (mapcar (lambda (node) - (cond - ((stringp node) (cl-ppcre:regex-replace-all "[ \r\n]+" node " ")) - ((equal "lkw" (cxml-xmls:node-name node)) - (format nil "&~A" (car (cxml-xmls:node-children node)))) - (t - (error "unexpected node ~A in lambda-list documentation")))) - nodes))))) - -(defun cleanup-arglist (arglist) - "Remove &rest argument from the given lambda list if there are -arguments following the &rest argument." - (do ((rest arglist (cdr rest)) - result) - ((null rest) (nreverse result)) - (if (and (eq (car rest) '&rest) - (cddr rest)) - (setf rest (cdr rest)) - (push (car rest) result)))) - -(defun check-function-argument-documentation () - (do-documented-names (symbol-name symbol-type node) - (when (find symbol-type '("function" "reader" "accessor") :test #'equal) - (handler-case - (fdefinition (find-symbol symbol-name :hunchentoot)) - (error (e) - (declare (ignore e)) - (return))) - (let* ((real-arglist (cleanup-arglist (swank::arglist (find-symbol symbol-name :hunchentoot)))) - (real-arglist-string (princ-to-string - (or real-arglist - "()"))) - (documented-arglist-string (arglist-from-xml-lambda-list - (cxml-xmls:node-children - (find-if (lambda (node) - (and (listp node) - (equal "lambda-list" (cxml-xmls:node-name node)))) - (cxml-xmls:node-children node)))))) - (when (and (= 1 (length real-arglist)) - (cl-ppcre:scan "(\S+)" documented-arglist-string)) - ;; For single-argument functions, do not report argument - ;; name mismatches as the real argument name is often - ;; generated by the compiler in reader/writer/accessor slot - ;; options. - (return)) - (unless (equal real-arglist-string documented-arglist-string) - (format t "documented arglist for ~A ~A~% ~A~%deviates from real arglist~% ~A~%~%" - symbol-type symbol-name documented-arglist-string real-arglist-string)))))) - -(defun node-text (node) - (let (strings) - (labels ((recurse (node) - (if (stringp node) - (push node strings) - (mapc #'recurse (cxml-xmls:node-children node))))) - (recurse node) - (apply #'concatenate 'string (nreverse strings))))) - -(defun clean-string (string) - (string-trim " " (cl-ppcre:regex-replace-all "[\r\n]+\s*" string " "))) - -(defun dump-docstring-and-description () - (do-documented-names (symbol-name symbol-type node) - (when (find symbol-type '("function" "accessor") :test #'equal) - (let ((docstring (clean-string (documentation (find-symbol symbol-name :hunchentoot) 'function))) - (documentation-string (clean-string - (node-text (find "description" (remove-if-not #'listp (cxml-xmls:node-children node)) - :key #'cxml-xmls:node-name :test #'equal))))) - (format t "----~%~A:~%~A~%~%~A~%~%" symbol-name - docstring - documentation-string))))) - -(defun exported-names () - "Return list of strings, the symbols that are exported from the Hunchentoot package" - (let (names) - (do-external-symbols (symbol :hunchentoot) - (pushnew (symbol-name symbol) names)) - names)) - -(defun check-doc () - (format t "---------------------~%") - (let* ((documented (documented-names)) - (exported (exported-names)) - (not-exported (sort (set-difference documented exported :test #'equal) #'string-lessp)) - (not-documented (sort (set-difference exported documented :test #'equal) #'string-lessp))) - (when not-exported - (format t "Documented, but not exported: ~{~& ~A~}~%~%" not-exported)) - (when not-documented - (format t "Exported, but not documented: ~{~& ~A~}~%~%" not-documented))) - (check-function-argument-documentation)) \ No newline at end of file