[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/doc/check-doc.lisp
BKNR Commits
bknr at bknr.net
Thu Feb 19 01:29:37 UTC 2009
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
- , at 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
More information about the Bknr-cvs
mailing list