# HG changeset patch # User Dave Love # Date 945731395 0 # Node ID 6bdad766098e5dd283776c83288d27857ce2de8c # Parent d0ae74166ab09057d38fdfc90a5cd38ab139f9e6 *** empty log message *** diff -r d0ae74166ab0 -r 6bdad766098e lisp/textmodes/=ispell4.el --- a/lisp/textmodes/=ispell4.el Mon Dec 20 14:24:13 1999 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1114 +0,0 @@ -;;; ispell4.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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package provides a graceful interface to ispell, the GNU -;; spelling checker. - -;;; Code: - -(defgroup ispell4 nil - "Interface to GNU ISPELL version 4." - :prefix "ispell-" - :group 'applications) - -(defcustom ispell-have-new-look t - "Non-nil means use the `-r' option when running `look'." - :type 'boolean - :group 'ispell4) - -(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.") - -(defcustom ispell-command "ispell" - "Command for running Ispell." - :type 'string - :group 'ispell4) - -(defcustom 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 option. -The -S option is always passed to Ispell as the last parameter, -and need not be mentioned here." - :type '(repeat string) - :group 'ispell4) - -(defcustom ispell-look-command "look" - "*Command for running look." - :type 'string - :group 'ispell4) - -;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 "%s" (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 "%s" - (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 "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")) - -(defcustom ispell-highlight t - "*Non-nil means to highlight ispell words." - :type 'boolean - :group 'ispell4) - -(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. - -(defcustom 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\"" - :type '(choice (const nil) file) - :group 'ispell4) - - -(defcustom ispell-gnu-look-still-broken-p nil - "*t if GNU look -r can give different results with and without trailing `.*'. -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." - :type 'boolean - :group 'ispell4) - -;;;; 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))) - -(defcustom ispell-message-cite-regexp "^ \\|^\t" - "*Regular expression to match lines cited from one message into another." - :type 'regexp - :group 'ispell4) - -(defcustom 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 occurrence of that regular expression. -Otherwise, it must be a function which is called to get the limit." - :type '(choice string function) - :group 'ispell4) - -(defcustom ispell-message-limit (* 100 80) - "*Ispell-message will check no more than this number of characters." - :type 'integer - :group 'ispell4) - -;;;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)) - - ;; Don't spell-check the headers. - (rfc822-goto-eoh) - (forward-line 1) - (setq non-internal-message (looking-at "")) - - (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) - -;;; ispell4.el ends here