view lisp/textmodes/=ispell4.el @ 9494:9a4ed505445e

(facemenu-read-color, facemenu-colors): New fn, var. (facemenu-set-face, facemenu-set-face-from-menu, facemenu-after-change): Face property can take a list value; add to it rather than completely replacing the property. (facemenu-add-face, facemenu-discard-redundant-faces): New functions. (facemenu-set-foreground, facemenu-set-background) (facemenu-get-face, facemenu-foreground, facemenu-background): New functions and variables. Faces with names of the form fg:color and bg:color are now treated specially. (facemenu-update): Updated for above.

;;; ispell.el --- this is the GNU EMACS interface to GNU ISPELL version 4.

;;Copyright (C) 1990, 1991, 1993 Free Software Foundation, Inc.

;; Keywords: wp

;;This file is part of GNU Emacs.
;;
;;GNU Emacs is free software; you can redistribute it and/or modify
;;it under the terms of the GNU General Public License as published by
;;the Free Software Foundation; either version 2, or (at your option)
;;any later version.
;;
;;GNU Emacs is distributed in the hope that it will be useful,
;;but WITHOUT ANY WARRANTY; without even the implied warranty of
;;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;GNU General Public License for more details.
;;
;;You should have received a copy of the GNU General Public License
;;along with GNU Emacs; see the file COPYING.  If not, write to
;;the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; This package provides a graceful interface to ispell, the GNU
;; spelling checker.

;;; Code:

(defvar ispell-have-new-look t
  "Non-nil means use the `-r' option when running `look'.")

(defvar ispell-enable-tex-parser nil
  "Non-nil enables experimental TeX parser in Ispell for TeX-mode buffers.")

(defvar ispell-process nil "The process running Ispell")
(defvar ispell-next-message nil
  "An integer: where in `*ispell*' buffer to find next message from Ispell.")

(defvar ispell-command "ispell"
  "Command for running Ispell.")
(defvar ispell-command-options nil
  "*String (or list of strings) to pass to Ispell as command arguments.
You can specify your private dictionary via the -p <filename> option.
The -S option is always passed to Ispell as the last parameter,
and need not be mentioned here.")

(defvar ispell-look-command "look"
  "*Command for running look.")

;Each marker in this list points to the start of a word that
;ispell thought was bad last time it did the :file command.
;Notice that if the user accepts or inserts a word into his
;private dictionary, then some "good" words will be on the list.
;We would like to deal with this by looking up the words again just before
;presenting them to the user, but that is too slow on machines
;without the select system call.  Therefore, see the variable
;ispell-recently-accepted.
(defvar ispell-bad-words nil
  "A list of markers reflecting the output of the Ispell `:file' command.")

;list of words that the user has accepted, but that might still
;be on the bad-words list
(defvar ispell-recently-accepted nil)

;; Non-nil means we have started showing an alternatives window.
;; This is the window config from before then.
(defvar ispell-window-configuration nil)

;t when :dump command needed
(defvar ispell-dump-needed nil)

(defun ispell-flush-bad-words ()
  (while ispell-bad-words
    (if (markerp (car ispell-bad-words))
        (set-marker (car ispell-bad-words) nil))
    (setq ispell-bad-words (cdr ispell-bad-words)))
  (setq ispell-recently-accepted nil))

(defun kill-ispell ()
  "Kill the Ispell process.
Any changes in your private dictionary
that have not already been dumped will be lost."
  (interactive)
  (if ispell-process
      (delete-process ispell-process))
  (setq ispell-process nil)
  (ispell-flush-bad-words))

(put 'ispell-startup-error 'error-conditions
     '(ispell-startup-error error))
(put 'ispell-startup-error 'error-message
     "Problem starting ispell - see buffer *ispell*")

;; Start an ispell subprocess; check the version; and display the greeting.

(defun start-ispell ()
  (message "Starting ispell ...")
  (let ((buf (get-buffer "*ispell*")))
    (if buf
	(kill-buffer buf)))
  (condition-case err
      (setq ispell-process
	    (apply 'start-process "ispell" "*ispell*" ispell-command
		   (append (if (listp ispell-command-options)
			       ispell-command-options
			     (list ispell-command-options))
			   '("-S"))))
    (file-error (signal 'ispell-startup-error nil)))
  (process-kill-without-query ispell-process)
  (buffer-disable-undo (process-buffer ispell-process))
  (accept-process-output ispell-process)
  (let (last-char)
    (save-excursion
      (set-buffer (process-buffer ispell-process))
      (bury-buffer (current-buffer))
      (setq last-char (- (point-max) 1))
      (while (not (eq (char-after last-char) ?=))
	(cond ((not (eq (process-status ispell-process) 'run))
	       (kill-ispell)
	       (signal 'ispell-startup-error nil)))
	(accept-process-output ispell-process)
	(setq last-char (- (point-max) 1)))
      (goto-char (point-min))
      (let ((greeting (read (current-buffer))))
	(if (not (= (car greeting) 1))
	    (error "Bad ispell version: wanted 1, got %d" (car greeting)))
	(message (car (cdr greeting))))
      (delete-region (point-min) last-char))))
  
;; Make sure ispell is ready for a command.
;; Leaves buffer set to *ispell*, point at '='.

(defun ispell-sync (intr)
  (if (or (null ispell-process)
	  (not (eq (process-status ispell-process) 'run)))
      (start-ispell))
  (if intr
      (interrupt-process ispell-process))
  (let (last-char)
    (set-buffer (process-buffer ispell-process))
    (bury-buffer (current-buffer))
    (setq last-char (- (point-max) 1))
    (while (not (eq (char-after last-char) ?=))
      (accept-process-output ispell-process)
      (setq last-char (- (point-max) 1)))
    (goto-char last-char)))

;; Send a command to ispell.  Choices are:
;; 
;; WORD		Check spelling of WORD.  Result is
;; 
;;			 nil			   not found
;;			 t			   spelled ok
;;			 list of strings		   near misses
;; 
;; :file FILENAME	scan the named file, and print the file offsets of
;;		 any misspelled words
;; 
;; :insert WORD	put word in private dictionary
;; 
;; :accept WORD	don't complain about word any more this session
;; 
;; :dump		write out the current private dictionary, if necessary.
;; 
;; :reload		reread private dictionary (default: `~/ispell.words')
;; 
;; :tex
;; :troff
;; :generic	set type of parser to use when scanning whole files

(defun ispell-cmd (&rest strings)
  (save-excursion
    (ispell-sync t)
    (set-buffer (process-buffer ispell-process))
    (bury-buffer (current-buffer))
    (erase-buffer)
    (setq ispell-next-message (point-min))
    (while strings
      (process-send-string ispell-process (car strings))
      (setq strings (cdr strings)))
    (process-send-string ispell-process "\n")
    (accept-process-output ispell-process)
    (ispell-sync nil)))

(defun ispell-dump ()
  (cond (ispell-dump-needed
	 (setq ispell-dump-needed nil)
	 (ispell-cmd ":dump"))))

(defun ispell-insert (word)
  (ispell-cmd ":insert " word)
  (if ispell-bad-words
      (setq ispell-recently-accepted (cons word ispell-recently-accepted)))
  (setq ispell-dump-needed t))

(defun ispell-accept (word)
  (ispell-cmd ":accept " word)
  (if ispell-bad-words
      (setq ispell-recently-accepted (cons word ispell-recently-accepted))))

;; Return the next message sent by the Ispell subprocess.

(defun ispell-next-message ()
  (save-excursion
    (set-buffer (process-buffer ispell-process))
    (bury-buffer (current-buffer))
    (save-restriction
      (goto-char ispell-next-message)
      (narrow-to-region (point)
                        (progn (forward-sexp 1) (point)))
      (setq ispell-next-message (point))
      (goto-char (point-min))
      (read (current-buffer)))))

(defun ispell-tex-buffer-p ()
  (memq major-mode '(plain-tex-mode latex-mode slitex-mode)))

(defvar ispell-menu-map (make-sparse-keymap "Spell"))
(defalias 'ispell-menu-map ispell-menu-map)

(define-key ispell-menu-map [ispell-complete-word-interior-frag]
  '("Complete Interior Fragment" . ispell-complete-word-interior-frag))

(define-key ispell-menu-map [ispell-complete-word]
  '("Complete Word" . ispell-complete-word))

(define-key ispell-menu-map [reload-ispell]
  '("Reload Dictionary" . reload-ispell))

(define-key ispell-menu-map [ispell-next]
  '("Continue Check" . ispell-next))

(define-key ispell-menu-map [ispell-message]
  '("Check Message" . ispell-message))

(define-key ispell-menu-map [ispell-word]
  '("Check Word" . ispell-word))

(define-key ispell-menu-map [ispell-region]
  '("Check Region" . ispell-region))

(define-key ispell-menu-map [ispell-buffer]
  '("Check Buffer" . ispell))

;;;###autoload
(defun ispell (&optional buf start end)
  "Run Ispell over current buffer's visited file.
First the file is scanned for misspelled words, then Ispell
enters a loop with the following commands for every misspelled word:

DIGIT	Near miss selector.  If the misspelled word is close to
	some words in the dictionary, they are offered as near misses.
r	Replace.  Replace the word with a string you type.  Each word
	of your new string is also checked.
i	Insert.  Insert this word in your private dictionary (by default,
	`$HOME/ispell.words').
a	Accept.  Accept this word for the rest of this editing session,
 	but don't put it in your private dictionary.
l	Lookup.  Look for a word in the dictionary by fast binary
	search, or search for a regular expression in the dictionary
	using grep.
SPACE	Accept the word this time, but complain if it is seen again.
q, \\[keyboard-quit]	Leave the command loop.  You can come back later with \\[ispell-next]."
  (interactive)
  (if (null start)
      (setq start 0))
  (if (null end)
      (setq end 0))

  (if (null buf)
      (setq buf (current-buffer)))
  (setq buf (get-buffer buf))
  (if (null buf)
      (error "Can't find buffer"))
  ;; Deactivate the mark, because we'll do it anyway if we change something,
  ;; and a region highlight while in the Ispell loop is distracting.
  (deactivate-mark)
  (save-excursion
    (set-buffer buf)
    (let ((filename buffer-file-name)
	  (delete-temp nil))
      (unwind-protect
	  (progn
	    (cond ((or (null filename)
		       (find-file-name-handler buffer-file-name nil))
		   (setq filename (make-temp-name "/usr/tmp/ispell"))
		   (setq delete-temp t)
		   (write-region (point-min) (point-max) filename))
		  ((and (buffer-modified-p buf)
			(y-or-n-p (format "Save file %s? " filename)))
		   (save-buffer)))
	    (message "Ispell scanning file...")
	    (if (and ispell-enable-tex-parser
		     (ispell-tex-buffer-p))
		(ispell-cmd ":tex")
	      (ispell-cmd ":generic"))
	    (ispell-cmd (format ":file %s %d %d" filename start end)))
	(if delete-temp
	    (condition-case ()
		(delete-file filename)
	      (file-error nil)))))
    (message "Parsing ispell output ...")
    (ispell-flush-bad-words)
    (let (pos bad-words)
      (while (numberp (setq pos (ispell-next-message)))
	;;ispell may check the words on the line following the end
	;;of the region - therefore, don't record anything out of range
	(if (or (= end 0)
		(< pos end))
	    (setq bad-words (cons (set-marker (make-marker) (+ pos 1))
				  bad-words))))
      (setq bad-words (cons pos bad-words))
      (setq ispell-bad-words (nreverse bad-words))))
  (cond ((not (markerp (car ispell-bad-words)))
	 (setq ispell-bad-words nil)
	 (message "No misspellings.")
	 t)
	(t
	 (message "Ispell parsing done.")
	 (ispell-next))))

;;;###autoload
(defalias 'ispell-buffer 'ispell)

(defun ispell-next ()
  "Resume command loop for most recent Ispell command.
Return value is t unless exit is due to typing `q'."
  (interactive)
  (setq ispell-window-configuration nil)
  (prog1
      (unwind-protect
	  (catch 'ispell-quit
	    ;; There used to be a save-excursion here,
	    ;; but that was annoying: it's better if point doesn't move
	    ;; when you type q.
	    (let (next)
	      (while (markerp (setq next (car ispell-bad-words)))
		(switch-to-buffer (marker-buffer next))
		(push-mark)
		(ispell-point next "at saved position.")
		(setq ispell-bad-words (cdr ispell-bad-words))
		(set-marker next nil)))
	    t)
	(ispell-dehighlight)
	(if ispell-window-configuration
	    (set-window-configuration ispell-window-configuration))
	(cond ((null ispell-bad-words)
	       (error "Ispell has not yet been run"))
	      ((markerp (car ispell-bad-words))
	       (message (substitute-command-keys
			   "Type \\[ispell-next] to continue")))
	      ((eq (car ispell-bad-words) nil)
	       (setq ispell-bad-words nil)
	       (message "No more misspellings (but checker was interrupted)"))
	      ((eq (car ispell-bad-words) t)
	       (setq ispell-bad-words nil)
	       (message "Ispell done"))
	      (t
	       (setq ispell-bad-words nil)
	       (message "Bad ispell internal list"))))
    (ispell-dump)))

;;;###autoload
(defun ispell-word (&optional resume)
  "Check the spelling of the word under the cursor.
See the command `ispell' for more information.
With a prefix argument, resume handling of the previous Ispell command."
  (interactive "P")
  (if resume
      (ispell-next)
    (condition-case err
	(unwind-protect
	    (catch 'ispell-quit
	      (save-window-excursion
		(ispell-point (point) "at point."))
	      (ispell-dump))
	  (ispell-dehighlight))
      (ispell-startup-error
       (cond ((y-or-n-p "Problem starting ispell, use old-style spell instead? ")
	      (load-library "spell")
	      (define-key esc-map "$" 'spell-word)
	      (spell-word)))))))

;;;###autoload (define-key esc-map "$" 'ispell-word)

;;;###autoload
(defun ispell-region (start &optional end)
  "Check the spelling for all of the words in the region."
  (interactive "r")
  (ispell (current-buffer) start end))

(defun ispell-letterp (c)
  (and c
       (or (and (>= c ?A) (<= c ?Z))
	   (and (>= c ?a) (<= c ?z))
	   (>= c 128))))

(defun ispell-letter-or-quotep (c)
  (and c
       (or (and (>= c ?A) (<= c ?Z))
	   (and (>= c ?a) (<= c ?z))
	   (= c ?')
	   (>= c 128))))

(defun ispell-find-word-start ()
  ;;backward to a letter
  (if (not (ispell-letterp (char-after (point))))
      (while (and (not (bobp))
		  (not (ispell-letterp (char-after (- (point) 1)))))
	(backward-char)))
  ;;backward to beginning of word
  (while (ispell-letter-or-quotep (char-after (- (point) 1)))
    (backward-char))
  (skip-chars-forward "'"))

(defun ispell-find-word-end ()
  (while (ispell-letter-or-quotep (char-after (point)))
    (forward-char))
  (skip-chars-backward "'"))

(defun ispell-next-word ()
  (while (and (not (eobp))
	      (not (ispell-letterp (char-after (point)))))
    (forward-char)))

;if end is nil, then do one word at start
;otherwise, do all words from the beginning of the word where
;start points, to the end of the word where end points
(defun ispell-point (start message)
  (let ((wend (make-marker))
	rescan
	end)
    ;; There used to be a save-excursion here,
    ;; but that was annoying: it's better if point doesn't move
    ;; when you type q.
    (goto-char start)
    (ispell-find-word-start)		;find correct word start
    (setq start (point-marker))
    (ispell-find-word-end)		;now find correct end
    (setq end (point-marker))
    ;; Do nothing if we don't find a word.
    (if (< start end)
	(while (< start end)
	  (goto-char start)
	  (ispell-find-word-end)	;find end of current word
					;could be before 'end' if
					;user typed replacement
					;that is more than one word
	  (set-marker wend (point))
	  (setq rescan nil)
	  (setq word (buffer-substring start wend))
	  (cond ((ispell-still-bad word)
;;; This just causes confusion. -- rms.
;;;	     (goto-char start)
;;;	     (sit-for 0)
		 (message (format "Ispell checking %s" word))
		 (ispell-cmd word)
		 (let ((message (ispell-next-message)))
		   (cond ((eq message t)
			  (message "%s: ok" word))
			 ((or (null message)
			      (consp message))
			  (setq rescan
				(ispell-command-loop word start wend message)))
			 (t
			  (error "unknown ispell response %s" message))))))
	  (cond ((null rescan)
		 (goto-char wend)
		 (ispell-next-word)
		 (set-marker start (point))))))
    ;;clear the choices buffer; otherwise it's hard for the user to tell
    ;;when we get back to the command loop
    (let ((buf (get-buffer "*ispell choices*")))
      (cond (buf
	     (set-buffer buf)
	     (erase-buffer))))
    (set-marker start nil)
    (set-marker end nil)
    (set-marker wend nil)))
  
(defun ispell-still-bad (word)
  (let ((words ispell-recently-accepted)
	(ret t)
	(case-fold-search t))
    (while words
      (cond ((eq (string-match (car words) word) 0)
	     (setq ret nil)
	     (setq words nil)))
      (setq words (cdr words)))
    ret))

(defun ispell-show-choices (word message first-line)
  ;;if there is only one window on the frame, make the ispell
  ;;messages winow be small.  otherwise just use the other window
  (let* ((selwin (selected-window))
	 (resize (eq selwin (next-window)))
	 (buf (get-buffer-create "*ispell choices*"))
	 w)
    (or ispell-window-configuration
	(setq ispell-window-configuration (current-window-configuration)))
    (setq w (display-buffer buf))
    (buffer-disable-undo buf)
    (if resize
	(unwind-protect
	    (progn
	      (select-window w)
	      (enlarge-window (- 6 (window-height w))))
	  (select-window selwin)))
    (save-excursion
      (set-buffer buf)
      (bury-buffer buf)
      (set-window-point w (point-min))
      (set-window-start w (point-min))
      (erase-buffer)
      (insert first-line "\n")
      (insert
       "SPC skip; A accept; I insert; DIGIT select; R replace; \
L lookup; Q quit\n")
      (cond ((not (null message))
	     (let ((i 0))
	       (while (< i 3)
		 (let ((j 0))
		   (while (< j 3)
		     (let* ((n (+ (* j 3) i))
			    (choice (nth n message)))
		       (cond (choice
			      (let ((str (format "%d %s" n choice)))
				(insert str)
				(insert-char ?  (- 20 (length str)))))))
		     (setq j (+ j 1))))
		 (insert "\n")
		 (setq i (+ i 1)))))))))

(defun ispell-command-loop (word start end message)
  (let ((flag t)
	(rescan nil)
	first-line)
    (if (null message)
	(setq first-line (concat "No near misses for '" word "'"))
      (setq first-line (concat "Near misses for '" word "'")))
    (ispell-highlight start end)
    (while flag
      (ispell-show-choices word message first-line)
      (message "Ispell command: ")
      (undo-boundary)
      (let ((c (downcase (read-char)))
	    replacement)
	(cond ((and (>= c ?0)
		    (<= c ?9)
		    (setq replacement (nth (- c ?0) message)))
	       (ispell-replace start end replacement)
	       (setq flag nil))
	      ((= c ?q)
	       (throw 'ispell-quit nil))
	      ((= c (nth 3 (current-input-mode)))
	       (keyboard-quit))
	      ((= c ? )
	       (setq flag nil))
	      ((= c ?r)
	       (ispell-replace start end (read-string "Replacement: "))
	       (setq rescan t)
	       (setq flag nil))
	      ((= c ?i)
	       (ispell-insert word)
	       (setq flag nil))
	      ((= c ?a)
	       (ispell-accept word)
	       (setq flag nil))
	      ((= c ?l)
	       (let ((val (ispell-do-look word)))
		 (setq first-line (car val))
		 (setq message (cdr val))))
	      ((= c ??)
	       (message
		"Type 'C-h d ispell' to the emacs main loop for more help")
	       (sit-for 2))
	      (t
	       (message "Bad ispell command")
	       (sit-for 2)))))
    rescan))

(defun ispell-do-look (bad-word)
  (let (regex buf words)
    (cond ((null ispell-have-new-look)
	   (setq regex (read-string "Lookup: ")))
	  (t
	   (setq regex (read-string "Lookup (regex): " "^"))))
    (setq buf (get-buffer-create "*ispell look*"))
    (save-excursion
      (set-buffer buf)
      (delete-region (point-min) (point-max))
      (if ispell-have-new-look
	  (call-process ispell-look-command nil buf nil "-r" regex)
	(call-process ispell-look-command nil buf nil regex))
      (goto-char (point-min))
      (forward-line 10)
      (delete-region (point) (point-max))
      (goto-char (point-min))
      (while (not (= (point-min) (point-max)))
	(end-of-line)
	(setq words (cons (buffer-substring (point-min) (point)) words))
	(forward-line)
	(delete-region (point-min) (point)))
      (kill-buffer buf)
      (cons (format "Lookup '%s'" regex)
	    (reverse words)))))
    
(defun ispell-replace (start end new)
  (goto-char start)
  (insert new)
  (delete-region (point) end))

(defun reload-ispell ()
  "Tell Ispell to re-read your private dictionary."
  (interactive)
  (ispell-cmd ":reload"))

(defun batch-make-ispell ()
  (byte-compile-file "ispell.el")
  (find-file "ispell.texinfo")
  (let ((old-dir default-directory)
	(default-directory "/tmp"))
    (texinfo-format-buffer))
  (Info-validate)
  (if (get-buffer " *problems in info file*")
      (kill-emacs 1))
  (write-region (point-min) (point-max) "ispell.info"))

(defvar ispell-highlight t
  "*Non-nil means to highlight ispell words.")

(defvar ispell-overlay nil)

(defun ispell-dehighlight ()
  (and ispell-overlay
       (progn
	 (delete-overlay ispell-overlay)
	 (setq ispell-overlay nil))))

(defun ispell-highlight (start end)
  (and ispell-highlight 
       window-system
       (progn
	 (or ispell-overlay
	     (progn
	       (setq ispell-overlay (make-overlay start end))
	       (overlay-put ispell-overlay 'face
			    (if (internal-find-face 'ispell)
				'ispell 'region))))
	 (move-overlay ispell-overlay start end (current-buffer)))))

;;;; ispell-complete-word

;;; Brief Description:
;;; Complete word fragment at point using dictionary and replace with full
;;; word.  Expansion done in current buffer like lisp-complete-symbol.
;;; Completion of interior word fragments possible with prefix argument.

;;; Known Problem: 
;;; Does not use private dictionary because GNU `look' does not use it.  It
;;; would be nice if GNU `look' took standard input; this would allow gzip'ed
;;; dictionaries to be used.  GNU `look' also has a bug, see
;;; `ispell-gnu-look-still-broken-p'.

;;; Motivation: 
;;; The `l', "regular expression look up", keymap option of ispell-word
;;; (ispell-do-look) can only be run after finding a misspelled word.  So
;;; ispell-do-look can not be used to look for words starting with `cat' to
;;; find `catechetical' since `cat' is a correctly spelled word.  Furthermore,
;;; ispell-do-look does not return the entire list returned by `look'.
;;;  
;;; ispell-complete-word allows you to get a completion list from the system
;;; dictionary and expand a word fragment at the current position in a buffer.
;;; These examples assume ispell-complete-word is bound to M-TAB as it is in
;;; text-mode; the `Complete Word' and `Complete Interior Fragment' entries of
;;; the "Spell" submenu under the "Edit" menu may also be used instead of
;;; M-TAB and C-u M-TAB, respectively.
;;;
;;;   EXAMPLE 1: The word `Saskatchewan' needs to be spelled.  The user may
;;;   type `Sas' and hit M-TAB and a completion list will be built using the
;;;   shell command `look' and displayed in the *Completions* buffer:
;;;
;;;        Possible completions are:
;;;        sash                               sashay
;;;        sashayed                           sashed
;;;        sashes                             sashimi
;;;        Saskatchewan                       Saskatoon
;;;        sass                               sassafras
;;;        sassier                            sassing
;;;        sasswood                           sassy
;;;
;;;   By viewing this list the user will hopefully be motivated to insert the
;;;   letter `k' after the `sas'.  When M-TAB is hit again the word `Saskat'
;;;   will be inserted in place of `sas' (note case) since this is a unique
;;;   substring completion.  The narrowed completion list can be viewed with
;;;   another M-TAB
;;;
;;;        Possible completions are:
;;;        Saskatchewan                       Saskatoon
;;;
;;;   Inserting the letter `c' and hitting M-TAB will narrow the completion
;;;   possibilities to just `Saskatchewan' and this will be inserted in the
;;;   buffer.  At any point the user may click the mouse on a completion to
;;;   select it.
;;;
;;;   EXAMPLE 2: The user has typed `Sasaquane' and M-$ (ispell-word) gives no
;;;   "near-misses" in which case you back up to `Sas' and hit M-TAB and find
;;;   the correct word as above.  The `Sas' will be replaced by `Saskatchewan'
;;;   and the remaining word fragment `aquane' can be deleted.
;;;
;;;   EXAMPLE 3: If a version of `look' is used that supports regular
;;;   expressions, then `ispell-have-new-look' should be t (its default) and
;;;   interior word fragments may also be used for the search.  The word
;;;   `pneumonia' needs to be spelled.  The user can only remember the
;;;   interior fragment `mon' in which case `C-u M-TAB' on `mon' gives a list
;;;   of all words containing the interior word fragment `mon'.  Typing `p'
;;;   and M-TAB will narrow this list to all the words starting with `p' and
;;;   containing `mon' from which `pneumonia' can be found as above.

;;; The user-defined variables are:
;;;
;;;  ispell-look-command
;;;  ispell-look-dictionary
;;;  ispell-gnu-look-still-broken-p

;;; Algorithm (some similarity to lisp-complete-symbol):
;;;  
;;; * call-process on command ispell-look-command (default: "look") to find
;;;   words in ispell-look-dictionary matching `string' (or `regexp' if 
;;;   ispell-have-new-look is t).  Parse output and store results in 
;;;   ispell-lookup-completions-alist.
;;; 
;;; * Build completion list using try-completion and `string'
;;; 
;;; * Replace `string' in buffer with matched common substring completion.
;;; 
;;; * Display completion list only if there is no matched common substring.
;;; 
;;; * Rebuild ispell-lookup-completions-alist, on a next call, only when
;;;   beginning of word fragment has changed.
;;;  
;;; * Interior fragments searches are performed similarly with the exception
;;;   that the entire fragment at point is initially removed from the buffer,
;;;   the STRING passed to try-completion and all-completions is just "" and
;;;   not the interior fragment; this allows all completions containing the
;;;   interior fragment to be shown.  The location in the buffer is stored to
;;;   decide whether future completion narrowing of the current list should be
;;;   done or if a new list should be built.  See interior fragment example
;;;   above.
;;;
;;; * Robust searches are done using a `look' with -r (regular expression) 
;;;   switch if ispell-have-new-look is t.

;;;; User-defined variables.

(defvar ispell-look-dictionary nil
  "*If non-nil then spelling dictionary as string for `ispell-complete-word'.
Overrides default dictionary file such as \"/usr/dict/words\" or GNU look's
\"${prefix}/lib/ispell/ispell.words\"")

(defvar ispell-gnu-look-still-broken-p nil
  "*t if GNU look -r can give different results with and without trialing `.*'.
Example: `look -dfr \"^ya\" foo' returns nothing, while `look -dfr \"^ya.*\" foo'
returns `yacc', where `foo' is a dictionary file containing the three lines

   y
   y's
   yacc

Both commands should return `yacc'.  If `ispell-complete-word' erroneously
states that no completions exist for a string, then setting this variable to t
will help find those completions.")

;;;; Internal variables.

;;; Possible completions for last word fragment.
(defvar ispell-lookup-completions-alist nil)

;;; Last word fragment processed by `ispell-complete-word'.
(defvar ispell-lookup-last-word nil)

;;; Buffer local variables.

;;; Value of interior-frag in last call to `ispell-complete-word'.
(defvar ispell-lookup-last-interior-p nil)
(make-variable-buffer-local 'ispell-lookup-last-interior-p)
(put 'ispell-lookup-last-interior-p 'permanent-local t)

;;; Buffer position in last call to `ispell-complete-word'.
(defvar ispell-lookup-last-bow nil)
(make-variable-buffer-local 'ispell-lookup-last-bow)
(put 'ispell-lookup-last-bow 'permanent-local t)

;;;; Interactive functions.
;;;###autoload
(defun ispell-complete-word (&optional interior-frag)
  "Complete word using letters at point to word beginning using `look'.
With optional argument INTERIOR-FRAG, word fragment at point is assumed to be
an interior word fragment in which case `ispell-have-new-look' should be t.
See also `ispell-look-dictionary' and `ispell-gnu-look-still-broken-p'."

  (interactive "P")

  ;; `look' must support regexp expressions in order to perform an interior
  ;; fragment search.
  (if (and interior-frag (not ispell-have-new-look))
      (error (concat "Sorry, `ispell-have-new-look' is nil.  "
                     "You also will need GNU Ispell's `look'.")))

  (let* ((completion-ignore-case t)

         ;; Get location of beginning of word fragment.
         (bow (save-excursion (skip-chars-backward "a-zA-Z'") (point)))

         ;; Get the string to look up.
         (string (buffer-substring bow (point)))

         ;; Get regexp for which we search and, if necessary, an interior word
         ;; fragment.
         (regexp (if interior-frag
                     (concat "^.*" string ".*")
                   ;; If possible use fast binary search: no trailing `.*'.
                   (concat "^" string
                           (if ispell-gnu-look-still-broken-p ".*"))))

         ;; We want all completions for case of interior fragments so set
         ;; prefix to an empty string.
         (prefix (if interior-frag "" string))

         ;; Are we continuing from a previous interior fragment search?
         ;; Check last value of interior-word and if the point has moved.
         (continuing-an-interior-frag-p
          (and ispell-lookup-last-interior-p
               (equal ispell-lookup-last-bow bow)))

         ;; Are we starting a unique word fragment search?  Always t for
         ;; interior word fragment search.
         (new-unique-string-p
          (or interior-frag (null ispell-lookup-last-word)
              (let ((case-fold-search t))
                ;; Can we locate last word fragment as a substring of current
                ;; word fragment?  If the last word fragment is larger than
                ;; the current string then we will have to rebuild the list
                ;; later.
                (not (string-match
                      (concat "^" ispell-lookup-last-word) string)))))

         completion)

    ;; Check for perfect completion already.  That is, maybe the user has hit
    ;; M-x ispell-complete-word one too many times?
    (if (string-equal string "")
        (if (string-equal (concat ispell-lookup-last-word " ")
                          (buffer-substring
                           (save-excursion (forward-word -1) (point)) (point)))
            (error "Perfect match already")
          (error "No word fragment at point")))

    ;; Create list of words from system dictionary starting with `string' if
    ;; new string and not continuing from a previous interior fragment search.
    (if (and (not continuing-an-interior-frag-p) new-unique-string-p)
        (setq ispell-lookup-completions-alist
              (ispell-lookup-build-list string regexp)))

    ;; Check for a completion of `string' in the list and store `string' and
    ;; other variables for the next call.
    (setq completion (try-completion prefix ispell-lookup-completions-alist)
          ispell-lookup-last-word string
          ispell-lookup-last-interior-p interior-frag
          ispell-lookup-last-bow bow)

    ;; Test the completion status.
    (cond

     ;; * Guess is a perfect match.
     ((eq completion t)
      (insert " ")
      (message "Perfect match."))

     ;; * No possibilities.
     ((null completion)
      (message "Can't find completion for \"%s\"" string)
      (beep))

     ;; * Replace string fragment with matched common substring completion.
     ((and (not (string-equal completion ""))
           ;; Fold case so a completion list is built when `string' and common
           ;; substring differ only in case.
           (let ((case-fold-search t))
             (not (string-match (concat "^" completion "$") string))))
      (search-backward string bow)
      (replace-match completion nil t) ; FIXEDCASE doesn't work? or LITERAL?
      (message "Proposed unique substring.  Repeat for completions list."))

     ;; * String is a common substring completion already.  Make list.
     (t
      (message "Making completion list...")
      (if (string-equal completion "") (delete-region bow (point)))
      (let ((list (all-completions prefix ispell-lookup-completions-alist)))
        (with-output-to-temp-buffer "*Completions*"
          (display-completion-list list)))
      (message "Making completion list...done")))))

;;;###autoload
(defun ispell-complete-word-interior-frag ()
  "Runs `ispell-complete-word' with a non-nil INTERIOR-FRAG.
A completion list is built for word fragment at point which is assumed to be
an interior word fragment.  `ispell-have-new-look' should be t."
  (interactive)
  (ispell-complete-word t))

;;;; Internal Function.

;;; Build list of words using ispell-look-command from dictionary
;;; ispell-look-dictionary (if this is a non-nil string).  Look for words
;;; starting with STRING if ispell-have-new-look is nil or look for REGEXP if
;;; ispell-have-new-look is t.  Returns result as an alist suitable for use by
;;; try-completion, all-completions, and completing-read.
(defun ispell-lookup-build-list (string regexp)
  (save-excursion
    (message "Building list...")
    (set-buffer (get-buffer-create " *ispell look*"))
    (erase-buffer)

    (if (stringp ispell-look-dictionary)
        (if ispell-have-new-look
            (call-process ispell-look-command nil t nil "-fr" regexp
                          ispell-look-dictionary)
          (call-process ispell-look-command nil t nil "-f" string
                        ispell-look-dictionary))
      (if ispell-have-new-look
          (call-process ispell-look-command nil t nil "-fr" regexp)
        (call-process ispell-look-command nil t nil "-f" string)))

    ;; Build list for try-completion and all-completions by storing each line
    ;; of output starting from bottom of buffer and deleting upwards.
    (let (list)
      (goto-char (point-min))
      (while (not (= (point-min) (point-max)))
        (end-of-line)
        (setq list (cons (buffer-substring (point-min) (point)) list))
        (forward-line)
        (delete-region (point-min) (point)))

      ;; Clean.
      (erase-buffer)
      (message "Building list...done")

      ;; Make the list into an alist and return.
      (mapcar 'list (nreverse list)))))

;; Return regexp-quote of STRING if STRING is non-empty.
;; Otherwise return an unmatchable regexp.
(defun ispell-non-empty-string (string)
  (if (or (not string) (string-equal string ""))
      "\\'\\`" ; An unmatchable string if string is null.
    (regexp-quote string)))

(defvar ispell-message-cite-regexp "^   \\|^\t"
  "*Regular expression to match lines cited from one message into another.")

(defvar ispell-message-text-end
  (concat "^\\(" (mapconcat (function identity)
				'(
				  ;; Matches postscript files.
				  "%!PS-Adobe-2.0"
				  ;; Matches uuencoded text
				  "begin [0-9][0-9][0-9] .*\nM.*\nM.*\nM"
				  ;; Matches shell files (esp. auto-decoding)
				  "#! /bin/sh"
				  ;; Matches difference listing
				  "diff -c .*\n\\*\\*\\* .*\n--- "
				  ;; Matches "--------------------- cut here"
				  "[-=]+\\s cut here")
				"\\|")
	      "\\)")
  "*End of text which will be checked in ispell-message.
If it is a string, limit at first occurence of that regular expression.
Otherwise, it must be a function which is called to get the limit.")

(defvar ispell-message-limit (* 100 80)
  "*Ispell-message will check no more than this number of characters.")

;;;###autoload
(defun ispell-message ()
  "Check the spelling of a mail message or news post.
Don't check spelling of message headers (except subject) or included messages.

To spell-check whenever a message is sent, include this line in .emacs:
   (setq news-inews-hook (setq mail-send-hook 'ispell-message))

Or you can bind the function to C-c i in gnus or mail with:
   (setq mail-mode-hook (setq news-reply-mode-hook
    (function (lambda () (local-set-key \"\\C-ci\" 'ispell-message)))))"
  (interactive)
  (save-excursion
    (let (non-internal-message
	  (old-case-fold-search case-fold-search)
	  (case-fold-search nil))
      (goto-char (point-min))
      ;; Don't spell-check the headers.
      (if (search-forward mail-header-separator nil t)
	  ;; Move to first body line.
	  (forward-line 1)
	(while (and (looking-at "[a-zA-Z-]+:\\|\t\\| ")
		    (not (eobp)))
	  (forward-line 1))
	(setq non-internal-message t)
	)
      (let* ((cite-regexp		;Prefix of inserted text
	     (cond
	      ((featurep 'supercite)	; sc 3.0
	       (concat "\\(" (sc-cite-regexp) "\\)" "\\|"
		       (ispell-non-empty-string sc-reference-tag-string)))
	      ((featurep 'sc)		; sc 2.3
	       (concat "\\(" sc-cite-regexp "\\)" "\\|"
		       (ispell-non-empty-string sc-reference-tag-string)))
	      (non-internal-message	; Assume nn sent us this message.
	       (concat "In [a-zA-Z.]+ you write:" "\\|"
		       "In <[^,;&+=]+> [^,;&+=]+ writes:" "\\|"
		       " *> *"))
	      ((equal major-mode 'news-reply-mode) ;Gnus
	       (concat "In article <" "\\|"
		       (if mail-yank-prefix
			   (ispell-non-empty-string mail-yank-prefix)
			 ispell-message-cite-regexp)))
	      ((boundp 'vm-included-text-prefix) ; VM mail message
	       (concat "[^,;&+=]+ writes:" "\\|"
		       (ispell-non-empty-string vm-included-text-prefix)
		       ))
	      ((boundp 'mh-ins-buf-prefix) ; mh mail message
	       (ispell-non-empty-string mh-ins-buf-prefix))
	      (mail-yank-prefix			; vanilla mail message.
	       (ispell-non-empty-string mail-yank-prefix))
	      (t ispell-message-cite-regexp)))
	    (continue t)
	    (limit
	     (min
	      (+ (point-min) ispell-message-limit)
	      (point-max)
	      (save-excursion
 		(cond
 		 ((not ispell-message-text-end) (point-max))
 		 ((char-or-string-p ispell-message-text-end)
 		  (if (re-search-forward ispell-message-text-end nil 'end)
 		      (match-beginning 0)
 		    (point-max)))
 		 (t (funcall ispell-message-text-end))))))
	    (search-limit ; Search limit which won't stop in middle of citation
	     (+ limit (length cite-regexp)))
	    )
 	;; Check the subject
 	(save-excursion
 	  (let ((case-fold-search t)
 		(message-begin (point)))
 	    (goto-char (point-min))
 	    ;; "\\s *" matches newline if subject is empty
 	    (if (and (re-search-forward "^Subject:[\t ]*" message-begin t)
 		     (not (looking-at "re\\>")))
 		(setq continue
 		      (ispell-region (- (point) 1)
 				     (progn
				       (end-of-line)
				       (while (looking-at "\n[ \t]")
					 (end-of-line 2))
				       (point))))
 	      )))

	;; Check the body.
	(while (and (< (point) limit) continue)
	  ;; Skip across text cited from other messages.
	  (while (and (looking-at (concat "^[ \t]*$\\|" cite-regexp))
		      (< (point) limit))
	    (forward-line 1))
	  (if (< (point) limit)
	      ;; Check the next batch of lines that *aren't* cited.
	      (let ((start (point)))
		(if (re-search-forward
		     (concat "^\\(" cite-regexp "\\)") search-limit 'end)
		    (beginning-of-line))
		(if (> (point) limit) (goto-char limit))
		(let ((case-fold-search old-case-fold-search))
		  (save-excursion
		    (setq continue (ispell-region (- start 1) (point))))))))))))

(provide 'ispell)

;;; ispell.el ends here