mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-24 14:30:43 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/checkdoc.el: cl-defstruct + minor simplifications

Browse source 
(checkdoc-make-overlay, checkdoc-overlay-put, checkdoc-delete-overlay)
(checkdoc-overlay-start, checkdoc-overlay-end, checkdoc-char=)
(checkdoc-mode-line-update): Remove old compatibility aliases.
(checkdoc, checkdoc-interactive-loop):
Consolidate common code in if branches.
(checkdoc-error): New struct type.
(checkdoc-error-text, checkdoc-error-start, checkdoc-error-end)
(checkdoc-error-unfixable): Now defined by cl-defstruct.
This commit is contained in:
Stefan Monnier 2017-10-08 15:44:49 -04:00
parent 9613690f6e
commit 85b4e88194
1 changed files with 52 additions and 80 deletions
Download patch file Download diff file Expand all files Collapse all files

132
lisp/emacs-lisp/checkdoc.el
View file

@ -171,6 +171,7 @@
(defvar checkdoc-version "0.6.1"
"Release version of checkdoc you are currently running.")
(eval-when-compile (require 'cl-lib))
(require 'help-mode) ;; for help-xref-info-regexp
(require 'thingatpt) ;; for handy thing-at-point-looking-at
@ -436,23 +437,6 @@ be re-created.")
st)
"Syntax table used by checkdoc in document strings.")
;;; Compatibility
;;
(defalias 'checkdoc-make-overlay
(if (featurep 'xemacs) #'make-extent #'make-overlay))
(defalias 'checkdoc-overlay-put
(if (featurep 'xemacs) #'set-extent-property #'overlay-put))
(defalias 'checkdoc-delete-overlay
(if (featurep 'xemacs) #'delete-extent #'delete-overlay))
(defalias 'checkdoc-overlay-start
(if (featurep 'xemacs) #'extent-start #'overlay-start))
(defalias 'checkdoc-overlay-end
(if (featurep 'xemacs) #'extent-end #'overlay-end))
(defalias 'checkdoc-mode-line-update
(if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update))
(defalias 'checkdoc-char=
(if (featurep 'xemacs) #'char= #'=))
;;; User level commands
;;
;;;###autoload
@ -475,32 +459,31 @@ the users will view as each check is completed."
tmp)
(checkdoc-display-status-buffer status)
;; check the comments
(if (not buffer-file-name)
(setcar status "Not checked")
(if (checkdoc-file-comments-engine)
(setcar status "Errors")
(setcar status "Ok")))
(setcar (cdr status) "Checking...")
(setf (nth 0 status)
(cond
((not buffer-file-name) "Not checked")
((checkdoc-file-comments-engine) "Errors")
(t "Ok")))
(setf (nth 1 status) "Checking...")
(checkdoc-display-status-buffer status)
;; Check the documentation
(setq tmp (checkdoc-interactive nil t))
(if tmp
(setcar (cdr status) (format "%d Errors" (length tmp)))
(setcar (cdr status) "Ok"))
(setcar (cdr (cdr status)) "Checking...")
(setf (nth 1 status)
(if tmp (format "%d Errors" (length tmp)) "Ok"))
(setf (nth 2 status) "Checking...")
(checkdoc-display-status-buffer status)
;; Check the message text
(if (setq tmp (checkdoc-message-interactive nil t))
(setcar (cdr (cdr status)) (format "%d Errors" (length tmp)))
(setcar (cdr (cdr status)) "Ok"))
(setcar (cdr (cdr (cdr status))) "Checking...")
(setf (nth 2 status)
(if (setq tmp (checkdoc-message-interactive nil t))
(format "%d Errors" (length tmp))
"Ok"))
(setf (nth 3 status) "Checking...")
(checkdoc-display-status-buffer status)
;; Rogue spacing
(if (condition-case nil
(checkdoc-rogue-spaces nil t)
(error t))
(setcar (cdr (cdr (cdr status))) "Errors")
(setcar (cdr (cdr (cdr status))) "Ok"))
(setf (nth 3 status)
(if (ignore-errors (checkdoc-rogue-spaces nil t))
"Errors"
"Ok"))
(checkdoc-display-status-buffer status)))
(defun checkdoc-display-status-buffer (check)
@ -592,16 +575,16 @@ style."
(while err-list
(goto-char (cdr (car err-list)))
;; The cursor should be just in front of the offending doc string
(if (stringp (car (car err-list)))
(setq cdo (save-excursion (checkdoc-make-overlay
(setq cdo (if (stringp (car (car err-list)))
(save-excursion (make-overlay
(point) (progn (forward-sexp 1)
(point)))))
(setq cdo (checkdoc-make-overlay
(point))))
(make-overlay
(checkdoc-error-start (car (car err-list)))
(checkdoc-error-end (car (car err-list))))))
(unwind-protect
(progn
(checkdoc-overlay-put cdo 'face 'highlight)
(overlay-put cdo 'face 'highlight)
;; Make sure the whole doc string is visible if possible.
(sit-for 0)
(if (and (= (following-char) ?\")
@ -627,10 +610,10 @@ style."
(if (not (integerp c)) (setq c ??))
(cond
;; Exit condition
((checkdoc-char= c ?\C-g) (signal 'quit nil))
((eq c ?\C-g) (signal 'quit nil))
;; Request an auto-fix
((or (checkdoc-char= c ?y) (checkdoc-char= c ?f))
(checkdoc-delete-overlay cdo)
((memq c '(?y ?f))
(delete-overlay cdo)
(setq cdo nil)
(goto-char (cdr (car err-list)))
;; `automatic-then-never' tells the autofix function
@ -659,7 +642,7 @@ style."
"No Additional style errors. Continuing...")
(sit-for 2))))))
;; Move to the next error (if available)
((or (checkdoc-char= c ?n) (checkdoc-char= c ?\s))
((memq c '(?n ?\s))
(let ((ne (funcall findfunc nil)))
(if (not ne)
(if showstatus
@ -671,7 +654,7 @@ style."
(sit-for 2))
(setq err-list (cons ne err-list)))))
;; Go backwards in the list of errors
((or (checkdoc-char= c ?p) (checkdoc-char= c ?\C-?))
((memq c '(?p ?\C-?))
(if (/= (length err-list) 1)
(progn
(setq err-list (cdr err-list))
@ -680,10 +663,10 @@ style."
(message "No Previous Errors.")
(sit-for 2)))
;; Edit the buffer recursively.
((checkdoc-char= c ?e)
((eq c ?e)
(checkdoc-recursive-edit
(checkdoc-error-text (car (car err-list))))
(checkdoc-delete-overlay cdo)
(delete-overlay cdo)
(setq err-list (cdr err-list)) ;back up the error found.
(beginning-of-defun)
(let ((ne (funcall findfunc nil)))
@ -695,7 +678,7 @@ style."
(sit-for 2))
(setq err-list (cons ne err-list)))))
;; Quit checkdoc
((checkdoc-char= c ?q)
((eq c ?q)
(setq returnme err-list
err-list nil
begin (point)))
@ -723,7 +706,7 @@ style."
"C-h - Toggle this help buffer.")))
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Checkdoc Help*"))))))
(if cdo (checkdoc-delete-overlay cdo)))))
(if cdo (delete-overlay cdo)))))
(goto-char begin)
(if (get-buffer "*Checkdoc Help*") (kill-buffer "*Checkdoc Help*"))
(message "Checkdoc: Done.")
@ -1147,6 +1130,15 @@ Prefix argument is the same as for `checkdoc-defun'"
;; features and behaviors, so we need some ways of specifying
;; them, and making them easier to use in the wacked-out interfaces
;; people are requesting
(cl-defstruct (checkdoc-error
(:constructor nil)
(:constructor checkdoc--create-error (text start end &optional unfixable)))
(text nil :read-only t)
(start nil :read-only t)
(end nil :read-only t)
(unfixable nil :read-only t))
(defvar checkdoc-create-error-function #'checkdoc--create-error-for-checkdoc
"Function called when Checkdoc encounters an error.
Should accept as arguments (TEXT START END &optional UNFIXABLE).
@ -1155,7 +1147,7 @@ TEXT is the descriptive text of the error. START and END define the region
it is sensible to highlight when describing the problem.
Optional argument UNFIXABLE means that the error has no auto-fix available.
A list of the form (TEXT START END UNFIXABLE) is returned if we are not
An object of type `checkdoc-error' is returned if we are not
generating a buffered list of errors.")
(defun checkdoc-create-error (text start end &optional unfixable)
@ -1171,27 +1163,7 @@ TEXT, START, END and UNFIXABLE conform to
(if checkdoc-generate-compile-warnings-flag
(progn (checkdoc-error start text)
nil)
(list text start end unfixable)))
(defun checkdoc-error-text (err)
"Return the text specified in the checkdoc ERR."
;; string-p part is for backwards compatibility
(if (stringp err) err (car err)))
(defun checkdoc-error-start (err)
"Return the start point specified in the checkdoc ERR."
;; string-p part is for backwards compatibility
(if (stringp err) nil (nth 1 err)))
(defun checkdoc-error-end (err)
"Return the end point specified in the checkdoc ERR."
;; string-p part is for backwards compatibility
(if (stringp err) nil (nth 2 err)))
(defun checkdoc-error-unfixable (err)
"Return the t if we cannot autofix the error specified in the checkdoc ERR."
;; string-p part is for backwards compatibility
(if (stringp err) nil (nth 3 err)))
(checkdoc--create-error text start end unfixable)))
;;; Minor Mode specification
;;
@ -1342,7 +1314,7 @@ See the style guide in the Emacs Lisp manual for more details."
(if (and (not (nth 1 fp)) ; not a variable
(or (nth 2 fp) ; is interactive
checkdoc-force-docstrings-flag) ;or we always complain
(not (checkdoc-char= (following-char) ?\"))) ; no doc string
(not (eq (following-char) ?\"))) ; no doc string
;; Sometimes old code has comments where the documentation should
;; be. Let's see if we can find the comment, and offer to turn it
;; into documentation for them.
@ -1471,9 +1443,9 @@ regexp short cuts work. FP is the function defun information."
(if (> (point) e) (goto-char e)) ;of the form (defun n () "doc" nil)
(forward-char -1)
(cond
((and (checkdoc-char= (following-char) ?\")
((and (eq (following-char) ?\")
;; A backslashed double quote at the end of a sentence
(not (checkdoc-char= (preceding-char) ?\\)))
(not (eq (preceding-char) ?\\)))
;; We might have to add a period in this case
(forward-char -1)
(if (looking-at "[.!?]")
@ -1796,7 +1768,7 @@ function,command,variable,option or symbol." ms1))))))
(let ((lim (save-excursion
(end-of-line)
;; check string-continuation
(if (checkdoc-char= (preceding-char) ?\\)
(if (eq (preceding-char) ?\\)
(line-end-position 2)
(point))))
(rs nil) replace original (case-fold-search t))
@ -2593,12 +2565,12 @@ This function returns non-nil if the text was replaced.
This function will not modify `match-data'."
(if (and checkdoc-autofix-flag
(not (eq checkdoc-autofix-flag 'never)))
(let ((o (checkdoc-make-overlay start end))
(let ((o (make-overlay start end))
(ret nil)
(md (match-data)))
(unwind-protect
(progn
(checkdoc-overlay-put o 'face 'highlight)
(overlay-put o 'face 'highlight)
(if (or (eq checkdoc-autofix-flag 'automatic)
(eq checkdoc-autofix-flag 'automatic-then-never)
(and (eq checkdoc-autofix-flag 'semiautomatic)
@ -2615,9 +2587,9 @@ This function will not modify `match-data'."
(insert replacewith)
(if checkdoc-bouncy-flag (sit-for 0))
(setq ret t)))
(checkdoc-delete-overlay o)
(delete-overlay o)
(set-match-data md))
(checkdoc-delete-overlay o)
(delete-overlay o)
(set-match-data md))
(if (eq checkdoc-autofix-flag 'automatic-then-never)
(setq checkdoc-autofix-flag 'never))