(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))