Skip to content
Snippets Groups Projects
flyspell.el 59.6 KiB
Newer Older
	    (progn
	      (message "Spell Checking...%d%%"
		       (* 100 (/ (float (- (point) beg)) (- end beg))))
	      (setq count 0))
	  (setq count (+ 1 count)))
	(flyspell-word)
	(let ((cur (point)))
	  (forward-word 1)
	  (if (and (< (point) end) (> (point) (+ cur 1)))
	      (backward-char 1)))))
    (backward-char 1)
    (message "Spell Checking...done")
    (flyspell-word)))

;*---------------------------------------------------------------------*/
;*    flyspell-buffer ...                                              */
;*---------------------------------------------------------------------*/
(defun flyspell-buffer ()
  "Flyspell whole buffer."
  (interactive)
  (flyspell-region (point-min) (point-max)))

;*---------------------------------------------------------------------*/
;*    flyspell-overlay-p ...                                           */
;*---------------------------------------------------------------------*/
(defun flyspell-overlay-p (o)
  "A predicate that return true iff O is an overlay used by flyspell."
  (and (overlayp o) (overlay-get o 'flyspell-overlay)))

;*---------------------------------------------------------------------*/
;*    flyspell-delete-all-overlays ...                                 */
;*    -------------------------------------------------------------    */
;*    Remove all the overlays introduced by flyspell.                  */
;*---------------------------------------------------------------------*/
(defun flyspell-delete-all-overlays ()
  "Delete all the overlays used by flyspell."
  (let ((l (overlays-in (point-min) (point-max))))
    (while (consp l)
      (progn
	(if (flyspell-overlay-p (car l))
	    (delete-overlay (car l)))
	(setq l (cdr l))))))

;*---------------------------------------------------------------------*/
;*    flyspell-unhighlight-at ...                                      */
;*---------------------------------------------------------------------*/
(defun flyspell-unhighlight-at (pos)
  "Remove the flyspell overlay that are located at POS."
  (if flyspell-persistent-highlight
      (let ((overlays (overlays-at pos)))
	(while (consp overlays)
	  (if (flyspell-overlay-p (car overlays))
	      (delete-overlay (car overlays)))
	  (setq overlays (cdr overlays))))
    (delete-overlay flyspell-overlay)))

;*---------------------------------------------------------------------*/
;*    flyspell-properties-at-p ...                                     */
;*    -------------------------------------------------------------    */
;*    Is there an highlight properties at position pos?                */
;*---------------------------------------------------------------------*/
(defun flyspell-properties-at-p (pos)
  "Return t if there is a text property at POS, not counting `local-map'.
If variable `flyspell-highlight-properties' is set to nil,
text with properties are not checked.  This function is used to discover
if the character at POS has any other property."
  (let ((prop (text-properties-at pos))
	(keep t))
    (while (and keep (consp prop))
      (if (and (eq (car prop) 'local-map) (consp (cdr prop)))
	  (setq prop (cdr (cdr prop)))
	(setq keep nil)))
    (consp prop)))

;*---------------------------------------------------------------------*/
;*    make-flyspell-overlay ...                                        */
;*---------------------------------------------------------------------*/
(defun make-flyspell-overlay (beg end face mouse-face)
  "Allocate an overlay to highlight an incorrect word.
BEG and END specify the range in the buffer of that word.
FACE and MOUSE-FACE specify the `face' and `mouse-face' properties
for the overlay."
  (let ((flyspell-overlay (make-overlay beg end)))
    (overlay-put flyspell-overlay 'face face)
    (overlay-put flyspell-overlay 'mouse-face mouse-face)
    (overlay-put flyspell-overlay 'flyspell-overlay t)
    (if (eq flyspell-emacs 'xemacs)
	(overlay-put flyspell-overlay
		     flyspell-overlay-keymap-property-name
		     flyspell-mouse-map))))
    
;*---------------------------------------------------------------------*/
;*    flyspell-highlight-incorrect-region ...                          */
;*---------------------------------------------------------------------*/
(defun flyspell-highlight-incorrect-region (beg end)
  "Set up an overlay on a misspelled word, in the buffer from BEG to END."
  (run-hook-with-args 'flyspell-incorrect-hook beg end)
  (if (or flyspell-highlight-properties (not (flyspell-properties-at-p beg)))
      (progn
	;; we cleanup current overlay at the same position
	(if (and (not flyspell-persistent-highlight)
		 (overlayp flyspell-overlay))
	    (delete-overlay flyspell-overlay)
	  (let ((overlays (overlays-at beg)))
	    (while (consp overlays)
	      (if (flyspell-overlay-p (car overlays))
		  (delete-overlay (car overlays)))
	      (setq overlays (cdr overlays)))))
	;; now we can use a new overlay
	(setq flyspell-overlay
	      (make-flyspell-overlay beg end
				     'flyspell-incorrect-face 'highlight)))))

;*---------------------------------------------------------------------*/
;*    flyspell-highlight-duplicate-region ...                          */
;*---------------------------------------------------------------------*/
(defun flyspell-highlight-duplicate-region (beg end)
  "Set up an overlay on a duplicated word, in the buffer from BEG to END."
  (if (or flyspell-highlight-properties (not (flyspell-properties-at-p beg)))
      (progn
	;; we cleanup current overlay at the same position
	(if (and (not flyspell-persistent-highlight)
		 (overlayp flyspell-overlay))
	    (delete-overlay flyspell-overlay)
	  (let ((overlays (overlays-at beg)))
	    (while (consp overlays)
	      (if (flyspell-overlay-p (car overlays))
		  (delete-overlay (car overlays)))
	      (setq overlays (cdr overlays)))))
	;; now we can use a new overlay
	(setq flyspell-overlay
	      (make-flyspell-overlay beg end
				     'flyspell-duplicate-face 'highlight)))))

;*---------------------------------------------------------------------*/
;*    flyspell-auto-correct-cache ...                                  */
;*---------------------------------------------------------------------*/
(defvar flyspell-auto-correct-pos nil)
(defvar flyspell-auto-correct-region nil)
(defvar flyspell-auto-correct-ring nil)

;*---------------------------------------------------------------------*/
;*    flyspell-auto-correct-word ...                                   */
;*---------------------------------------------------------------------*/
(defun flyspell-auto-correct-word (pos)
  "Correct the word at POS.
This command proposes various successive corrections for the word at POS.
The variable `flyspell-auto-correct-binding' specifies the key to bind
to this command."
  (interactive "d")
  ;; use the correct dictionary
steveb's avatar
steveb committed
  (flyspell-accept-buffer-local-defs)
  (if (eq flyspell-auto-correct-pos pos)
      ;; we have already been using the function at the same location
      (progn
	(save-excursion
	  (let ((start (car flyspell-auto-correct-region))
		(len   (cdr flyspell-auto-correct-region)))
	    (delete-region start (+ start len))
	    (setq flyspell-auto-correct-ring (cdr flyspell-auto-correct-ring))
	    (let* ((word (car flyspell-auto-correct-ring))
		   (len  (length word)))
	      (rplacd flyspell-auto-correct-region len)
	      (goto-char start)
	      (insert word))))
	(setq flyspell-auto-correct-pos (point)))
    ;; retain cursor location
    (let ((cursor-location pos)
steveb's avatar
steveb committed
	  (word (flyspell-get-word nil nil))
	  start end poss)
      ;; destructure return word info list.
      (setq start (car (cdr word))
	    end (car (cdr (cdr word)))
	    word (car word))
      ;; now check spelling of word.
      (process-send-string ispell-process "%\n") ;put in verbose mode
      (process-send-string ispell-process (concat "^" word "\n"))
      ;; wait until ispell has processed word
      (while (progn
	       (accept-process-output ispell-process)
	       (not (string= "" (car ispell-filter)))))
      (setq ispell-filter (cdr ispell-filter))
steveb's avatar
steveb committed
      (if (consp ispell-filter)
	  (setq poss (ispell-parse-output (car ispell-filter))))
      (cond ((or (eq poss t) (stringp poss))
	     ;; don't correct word
	     t)
	    ((null poss)
	     ;; ispell error
	     (error "Ispell: error in Ispell process"))
	    (t
	     ;; the word is incorrect, we have to propose a replacement
	     (let ((replacements (if flyspell-sort-corrections
				     (sort (car (cdr (cdr poss))) 'string<)
				   (car (cdr (cdr poss))))))
	       (if (consp replacements)
		   (progn
		     (let ((replace (car replacements)))
		       (setq word replace)
		       (setq cursor-location (+ (- (length word) (- end start))
						cursor-location))
		       (if (not (equal word (car poss)))
			   (progn
			     ;; the save the current replacements
			     (setq flyspell-auto-correct-pos cursor-location)
			     (setq flyspell-auto-correct-region
				   (cons start (length word)))
			     (let ((l replacements))
			       (while (consp (cdr l))
				 (setq l (cdr l)))
			       (rplacd l (cons (car poss) replacements)))
			     (setq flyspell-auto-correct-ring
				   (cdr replacements))
			     (delete-region start end)
			     (insert word)))))))))
      ;; return to original location
      (goto-char cursor-location)
      (ispell-pdict-save t))))

;*---------------------------------------------------------------------*/
;*    flyspell-correct-word ...                                        */
;*---------------------------------------------------------------------*/
(defun flyspell-correct-word (event)
  "Check spelling of word under or before the cursor.
If the word is not found in dictionary, display possible corrections
in a popup menu allowing you to choose one.

Word syntax described by `ispell-dictionary-alist' (which see).

This will check or reload the dictionary.  Use \\[ispell-change-dictionary]
or \\[ispell-region] to update the Ispell process."
  (interactive "e")
  (if (eq flyspell-emacs 'xemacs)
      (flyspell-correct-word/mouse-keymap event)
      (flyspell-correct-word/local-keymap event)))
    
;*---------------------------------------------------------------------*/
;*    flyspell-correct-word/local-keymap ...                           */
;*---------------------------------------------------------------------*/
(defun flyspell-correct-word/local-keymap (event)
  "emacs 19.xx seems to be buggous. Overlay keymap does not seems
to work correctly with local map. That is, if a key is not
defined for the overlay keymap, the current local map, is not
checked. The binding is resolved with the global map. The
consequence is that we can not use overlay map with flyspell."
  (interactive "e")
  (save-window-excursion
    (let ((save (point)))
      (mouse-set-point event)
      ;; we look for a flyspell overlay here
      (let ((overlays (overlays-at (point)))
	    (overlay  nil))
	(while (consp overlays)
	  (if (flyspell-overlay-p (car overlays))
	      (progn
		(setq overlay (car overlays))
		(setq overlays nil))
	    (setq overlays (cdr overlays))))
	;; we return to the correct location
	(goto-char save)
	;; we check to see if button2 has been used overlay a
	;; flyspell overlay
	(if overlay
	    ;; yes, so we use the flyspell function
	    (flyspell-correct-word/mouse-keymap event)
	  ;; no so we have to use the non flyspell binding
	  (let ((flyspell-mode nil))
	    (if (key-binding (this-command-keys))
		(command-execute (key-binding (this-command-keys))))))))))
  
;*---------------------------------------------------------------------*/
;*    flyspell-correct-word ...                                        */
;*---------------------------------------------------------------------*/
(defun flyspell-correct-word/mouse-keymap (event)
  "Pop up a menu of possible corrections for a misspelled word.
The word checked is the word at the mouse position."
  (interactive "e")
  ;; use the correct dictionary
steveb's avatar
steveb committed
  (flyspell-accept-buffer-local-defs)
  ;; retain cursor location (I don't know why but save-excursion here fails).
  (let ((save (point)))
    (mouse-set-point event)
    (let ((cursor-location (point))
steveb's avatar
steveb committed
	  (word (flyspell-get-word nil nil))
	  start end poss replace)
      ;; destructure return word info list.
      (setq start (car (cdr word))
	    end (car (cdr (cdr word)))
	    word (car word))
      ;; now check spelling of word.
      (process-send-string ispell-process "%\n") ;put in verbose mode
      (process-send-string ispell-process (concat "^" word "\n"))
      ;; wait until ispell has processed word
      (while (progn
	       (accept-process-output ispell-process)
	       (not (string= "" (car ispell-filter)))))
      (setq ispell-filter (cdr ispell-filter))
steveb's avatar
steveb committed
      (if (consp ispell-filter)
	  (setq poss (ispell-parse-output (car ispell-filter))))
      (cond ((or (eq poss t) (stringp poss))
	     ;; don't correct word
	     t)
	    ((null poss)
	     ;; ispell error
	     (error "Ispell: error in Ispell process"))
	    ((string-match "GNU" (emacs-version))
	     ;; the word is incorrect, we have to propose a replacement
	     (setq replace (flyspell-emacs-popup event poss word))
	     (cond ((eq replace 'ignore)
		    nil)
		   ((eq replace 'save)
		    (process-send-string ispell-process (concat "*" word "\n"))
		    (flyspell-unhighlight-at cursor-location)
		    (setq ispell-pdict-modified-p '(t)))
		   ((or (eq replace 'buffer) (eq replace 'session))
		    (process-send-string ispell-process (concat "@" word "\n"))
		    (if (null ispell-pdict-modified-p)
			(setq ispell-pdict-modified-p
			      (list ispell-pdict-modified-p)))
		    (flyspell-unhighlight-at cursor-location)
		    (if (eq replace 'buffer)
			(ispell-add-per-file-word-list word)))
		   (replace
		    (setq word (if (atom replace) replace (car replace))
			  cursor-location (+ (- (length word) (- end start))
					     cursor-location))
		    (if (not (equal word (car poss)))
			(progn
			  (delete-region start end)
			  (insert word))))))
	    ((string-match "XEmacs" (emacs-version))
	     (flyspell-xemacs-popup
	      event poss word cursor-location start end)))
      (ispell-pdict-save t))
    (if (< save (point-max))
	(goto-char save)
      (goto-char (point-max)))))

;*---------------------------------------------------------------------*/
;*    flyspell-xemacs-correct ...                                      */
;*---------------------------------------------------------------------*/
(defun flyspell-xemacs-correct (replace poss word cursor-location start end)
  "The xemacs popup menu callback."
  (cond ((eq replace 'ignore)
	 nil)
	((eq replace 'save)
	 (process-send-string ispell-process (concat "*" word "\n"))
	 (flyspell-unhighlight-at cursor-location)
	 (setq ispell-pdict-modified-p '(t)))
	((or (eq replace 'buffer) (eq replace 'session))
	 (process-send-string ispell-process (concat "@" word "\n"))
	 (flyspell-unhighlight-at cursor-location)
	 (if (null ispell-pdict-modified-p)
	     (setq ispell-pdict-modified-p
		   (list ispell-pdict-modified-p)))
	 (if (eq replace 'buffer)
	     (ispell-add-per-file-word-list word)))
	(replace
	 (setq word (if (atom replace) replace (car replace))
	       cursor-location (+ (- (length word) (- end start))
				  cursor-location))
	 (if (not (equal word (car poss)))
	     (save-excursion
	       (delete-region start end)
	       (goto-char start)
	       (insert word))))))

;*---------------------------------------------------------------------*/
;*    flyspell-emacs-popup ...                                         */
;*---------------------------------------------------------------------*/
(defun flyspell-emacs-popup (event poss word)
  "The Emacs popup menu."
  (if (not event)
      (let* ((mouse-pos  (mouse-position))
	     (mouse-pos  (if (nth 1 mouse-pos)
			     mouse-pos
			   (set-mouse-position (car mouse-pos)
					       (/ (frame-width) 2) 2)
			   (unfocus-frame)
			   (mouse-position))))
	(setq event (list (list (car (cdr mouse-pos))
				(1+ (cdr (cdr mouse-pos))))
			  (car mouse-pos)))))
  (let* ((corrects   (if flyspell-sort-corrections
			 (sort (car (cdr (cdr poss))) 'string<)
		       (car (cdr (cdr poss)))))
	 (cor-menu   (if (consp corrects)
			 (mapcar (lambda (correct)
				   (list correct correct))
				 corrects)
		       '()))
	 (affix      (car (cdr (cdr (cdr poss)))))
	 (base-menu  (let ((save (if (consp affix)
				     (list
				      (list (concat "Save affix: " (car affix))
					    'save)
				      '("Accept (session)" accept)
				      '("Accept (buffer)" buffer))
				   '(("Save word" save)
				     ("Accept (session)" session)
				     ("Accept (buffer)" buffer)))))
		       (if (consp cor-menu)
			   (append cor-menu (cons "" save))
			 save)))
	 (menu       (cons "flyspell correction menu" base-menu)))
    (car (x-popup-menu event
		       (list (format "%s [%s]" word (or ispell-local-dictionary
							ispell-dictionary))
			     menu)))))

;*---------------------------------------------------------------------*/
;*    flyspell-xemacs-popup ...                                        */
;*---------------------------------------------------------------------*/
(defun flyspell-xemacs-popup (event poss word cursor-location start end)
  "The xemacs popup menu."
  (let* ((corrects   (if flyspell-sort-corrections
			 (sort (car (cdr (cdr poss))) 'string<)
		       (car (cdr (cdr poss)))))
	 (cor-menu   (if (consp corrects)
			 (mapcar (lambda (correct)
				   (vector correct
					   (list 'flyspell-xemacs-correct
						 correct
						 (list 'quote poss)
						 word
						 cursor-location
						 start
						 end)
					   t))
				 corrects)
		       '()))
	 (affix      (car (cdr (cdr (cdr poss)))))
	 (menu       (let ((save (if (consp affix)
				     (vector
				      (concat "Save affix: " (car affix))
				      (list 'flyspell-xemacs-correct
					    ''save
					    (list 'quote poss)
					    word
					    cursor-location
					    start
					    end)
				      t)
				   (vector
				    "Save word"
				    (list 'flyspell-xemacs-correct
					  ''save
					  (list 'quote poss)
					  word
					  cursor-location
					  start
					  end)
				    t)))
			   (session (vector "Accept (session)"
					    (list 'flyspell-xemacs-correct
						  ''session
						  (list 'quote poss)
						  word
						  cursor-location
						  start
						  end)
					    t))
			   (buffer  (vector "Accept (buffer)"
					    (list 'flyspell-xemacs-correct
						  ''buffer
						  (list 'quote poss)
						  word
						  cursor-location
						  start
						  end)
					    t)))
		       (if (consp cor-menu)
			   (append cor-menu (list "-" save session buffer))
			 (list save session buffer)))))
    (popup-menu (cons (format "%s [%s]" word (or ispell-local-dictionary
						 ispell-dictionary))
		      menu))))

steveb's avatar
steveb committed
;;;###autoload
(if (fboundp 'add-minor-mode)
    (add-minor-mode 'flyspell-mode
		    flyspell-mode-line-string
		    flyspell-mode-map
		    nil
		    'flyspell-mode)
  (or (assoc 'flyspell-mode minor-mode-alist)
      (setq minor-mode-alist
	    (cons '(flyspell-mode flyspell-mode-line-string)
		  minor-mode-alist)))
steveb's avatar
steveb committed
  (or (assoc 'flyspell-mode minor-mode-map-alist)
      (setq minor-mode-map-alist
	    (cons (cons 'flyspell-mode flyspell-mode-map)
		  minor-mode-map-alist))))

(provide 'flyspell)
;;; flyspell.el ends here