(ispell-message): New command, with menu bar item.

[gnu-emacs] / lisp / textmodes / ispell4.el

;;; 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 use this to specify the name of your private dictionary.
The -S option is always passed to Ispell as the last parameter,
and need not be mentioned here.")

;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 `~/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)))

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

(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-region]
  '("Check Region" . ispell-region))

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

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

;;;###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 (kept in
        `$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 ((null filename)
                   (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
         (message "Ispell parsing done.")
         (ispell-next))))

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

(defun ispell-next ()
  "Resume command loop for most recent Ispell command."
  (interactive)
  (setq ispell-window-configuration nil)
  (unwind-protect
      (catch '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))))
    (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
        (catch 'quit
          (save-window-excursion
            (ispell-point (point) "at point."))
          (ispell-dump))
      (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 "'")))
    (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 'quit nil))
              ((= 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 "look" nil buf nil "-r" regex)
        (call-process "look" 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"))

(defun ispell-message ()
  "Check the spelling for an outgoing mail message."
  (interactive)
  (save-excursion
    (beginning-of-buffer)
    (search-forward mail-header-separator nil t)
    (ispell (current-buffer) (point))))

(provide 'ispell)

;;; ispell.el ends here