home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d1xx / d191 / ispell.lha / ISpell / unix.zoo / ispell.el < prev    next >
Lisp/Scheme  |  1989-02-22  |  23KB  |  500 lines
  1. ;;; Spelling correction interface for GNU EMACS using "ispell".
  2.  
  3. ;;; This file is not part of the GNU Emacs distribution (yet).
  4.  
  5. ;; This file is distributed in the hope that it will be useful,
  6. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  7. ;; accepts responsibility to anyone for the consequences of using it
  8. ;; or for whether it serves any particular purpose or works at all,
  9. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  10. ;; License for full details.
  11.  
  12. ;; Everyone is granted permission to copy, modify and redistribute
  13. ;; this file, but only under the conditions described in the
  14. ;; GNU Emacs General Public License.   A copy of this license is
  15. ;; supposed to have been given to you along with GNU Emacs so you
  16. ;; can know your rights and responsibilities.  It should be in a
  17. ;; file named COPYING.  Among other things, the copyright notice
  18. ;; and this notice must be preserved on all copies.
  19.  
  20. (provide 'ispell)
  21.  
  22. ;;; MODIFICATION HISTORY:
  23.  
  24. ;;; Ashwin Ram      ARPA:    Ram-Ashwin@cs.yale.edu
  25. ;;;                 UUCP:    ...!{decvax, linus, seismo}!yale!Ram-Ashwin
  26. ;;;                 BITNET:  Ram@yalecs
  27. ;;; Added variable to control embedded word checking (nice in troff but a pain otherwise).
  28. ;;; 10/26/87.
  29. ;;; Interactive word completion.
  30. ;;; 8/14/87.
  31. ;;; Detex before checking spelling.
  32. ;;; Made options more mnemonic, prompt and error messages better.
  33. ;;; Added highlighting of misspelled word.
  34. ;;; Query-replace all occurrences of misspelled word through buffer.
  35. ;;; Allow customization of personal dictionary.
  36. ;;; Moved temporary file to /tmp.
  37. ;;; Added check for dead ispell process to avoid infinite loop.
  38. ;;; Avoid repeated querying for same word in same buffer.
  39. ;;; 7/6/87.
  40.  
  41. ;;; Walt Buehring
  42. ;;; Texas Instruments - Computer Science Center
  43. ;;; ARPA:  Buehring%TI-CSL@CSNet-Relay
  44. ;;; UUCP:  {smu, texsun, im4u, rice} ! ti-csl ! buehring
  45.  
  46. ;;; ispell-region and associated routines added by
  47. ;;; Perry Smith
  48. ;;; pedz@bobkat
  49. ;;; Tue Jan 13 20:18:02 CST 1987
  50.  
  51. ;;; extensively modified by Mark Davies and Andrew Vignaux
  52. ;;; {mark,andrew}@vuwcomp
  53. ;;; Sun May 10 11:45:04 NZST 1987
  54.  
  55. ;;; Depends on the ispell program snarfed from MIT-PREP in early 1986.
  56.  
  57. ;;; To fully install this, add this file to your GNU lisp directory and 
  58. ;;; compile it with M-X byte-compile-file.  Then add the following to the
  59. ;;; appropriate init file:
  60. ;;; 
  61. ;;; (autoload 'ispell-word "ispell" "Check spelling of word at or before point" t)
  62. ;;; (autoload 'ispell-complete-word "ispell" "Complete word at or before point" t)
  63. ;;; (autoload 'ispell-region "ispell" "Check spelling of every word in the region" t)
  64. ;;; (autoload 'ispell-buffer "ispell" "Check spelling of every word in the buffer" t)
  65. ;;; You might want to bind ispell-word and ispell-complete word to keys.
  66.  
  67. ;;; If run on a heavily loaded system, the initial sleep time in
  68. ;;; ispell-init-process may need to be increased.
  69.  
  70. (defconst ispell-out-name " *ispell*"
  71.   "Name of the buffer that is associated with the 'ispell' process")
  72.  
  73. (defconst ispell-temp-name " *ispell-temp*"
  74.   "Name of the temporary buffer that 'ispell-region' uses to hold the
  75. filtered region")
  76.  
  77. (defvar ispell-program-name "ispell"
  78.   "Program invoked by ispell-word and ispell-region commands.")
  79.  
  80. (defvar ispell-dictionary
  81.    nil
  82.    "Personal dictionary file containing a list of words, one to a line.
  83. If nil, defaults to ispell's normal default (usually ~/.ispell_words).")
  84.  
  85. (defvar ispell-words-have-boundaries t
  86.    "If nil, a misspelled word matches embedded words too.  This is useful in
  87. nroff/troff, where a misspelled word may be hidded (e.g., \fIword\fB), and a
  88. pain otherwise.")
  89.  
  90. (defvar ispell-syntax-table nil)
  91.  
  92. (if (null ispell-syntax-table)
  93.     ;; The following assumes that the standard-syntax-table
  94.     ;; is static.  If you add words with funky characters
  95.     ;; to your dictionary, the following may have to change.
  96.     (progn
  97.       (setq ispell-syntax-table (make-syntax-table))
  98.       ;; Make certain characters word constituents
  99.       ;; (modify-syntax-entry ?' "w   " ispell-syntax-table)
  100.       ;; (modify-syntax-entry ?- "w   " ispell-syntax-table)
  101.       ;; Get rid on existing word syntax on certain characters 
  102.       (modify-syntax-entry ?0 ".   " ispell-syntax-table)
  103.       (modify-syntax-entry ?1 ".   " ispell-syntax-table)
  104.       (modify-syntax-entry ?2 ".   " ispell-syntax-table)
  105.       (modify-syntax-entry ?3 ".   " ispell-syntax-table)
  106.       (modify-syntax-entry ?4 ".   " ispell-syntax-table)
  107.       (modify-syntax-entry ?5 ".   " ispell-syntax-table)
  108.       (modify-syntax-entry ?6 ".   " ispell-syntax-table)
  109.       (modify-syntax-entry ?7 ".   " ispell-syntax-table)
  110.       (modify-syntax-entry ?8 ".   " ispell-syntax-table)
  111.       (modify-syntax-entry ?9 ".   " ispell-syntax-table)
  112.       (modify-syntax-entry ?$ ".   " ispell-syntax-table)
  113.       (modify-syntax-entry ?% ".   " ispell-syntax-table)))
  114.  
  115.  
  116. (defun ispell-word (&optional quietly)
  117.    "Check spelling of word at or before dot.
  118. If word not found in dictionary, display possible corrections in a window 
  119. and let user select."
  120.    (interactive)
  121.    (let* ((current-syntax (syntax-table))
  122.           start end word poss replace)
  123.       (unwind-protect
  124.             (save-excursion
  125.                (set-syntax-table ispell-syntax-table)            ;; Ensure syntax table is reasonable 
  126.                (if (not (looking-at "\\w"))
  127.                    (re-search-backward "\\w" (point-min) 'stay)) ;; Move backward for word if not already on one
  128.                (re-search-backward "\\W" (point-min) 'stay)      ;; Move to start of word
  129.                (or (re-search-forward "\\w+" nil t)              ;; Find start and end of word
  130.                    (error "No word to check."))
  131.                (setq start (match-beginning 0)
  132.                      end (match-end 0)
  133.                      word (buffer-substring start end)))
  134.          (set-syntax-table current-syntax))
  135.       (ispell-init-process)   ;; erases ispell output buffer
  136.       (or quietly (message "Checking spelling of %s..." (upcase word)))
  137.       (save-excursion
  138.          (set-buffer ispell-out-name)
  139.          (send-string ispell-process (concat word "\n"))
  140.          (while (progn                                         ;; Wait until we have a complete line
  141.                    (goto-char (point-max))
  142.                    (/= (preceding-char) ?\n))
  143.             (accept-process-output ispell-process))
  144.          (goto-char (point-min))
  145.          (setq poss (ispell-parse-output
  146.                        (buffer-substring (point) 
  147.                                          (progn (end-of-line) (point))))))
  148.       (cond ((eq poss t)
  149.              (or quietly (message "Checking spelling of %s... correct" (upcase word))))
  150.             ((stringp poss)
  151.              (or quietly (message "Checking spelling of %s... correct (derived from %s)" (upcase word) (upcase poss))))
  152. ;           ((null poss)
  153. ;            (or quietly (message "Checking spelling of %s... not found" (upcase word))))
  154.             (t (setq replace (ispell-choose poss word))
  155.                (if replace
  156.                    (progn
  157.                       (goto-char end)
  158.                       (delete-region start end)
  159.                       (insert-string replace)))))
  160.       poss))
  161.  
  162.  
  163. (defun ispell-choose (choices word)
  164.   "Display possible corrections from list CHOICES.  Return chosen word
  165. if one is chosen, or nil to keep original WORD."
  166.   (unwind-protect 
  167.       (save-window-excursion
  168.     (let ((count 0)
  169.           (line 2)
  170.           (words choices)
  171.           (window-min-height 2)
  172.           char num result)
  173.       (save-excursion
  174.         (set-buffer (get-buffer-create "*Choices*")) (erase-buffer)
  175.         (setq mode-line-format (concat "--  %b (Type number to select replacement for "
  176.                                            (upcase word)
  177.                                            ")  --"))
  178.         (while words
  179.           (if (<= (+ 7 (current-column) (length (car words)))
  180.               (window-width))
  181.           nil
  182.         (insert "\n")
  183.         (setq line (1+ line)))
  184.           (insert "(" (+ count ?0) ") " (car words) "  ")
  185.           (setq words (cdr words)
  186.             count (1+ count)))
  187.             (if (= count 0) (insert "(none)")))
  188.       (overlay-window line)
  189.       (switch-to-buffer "*Choices*")
  190.       (select-window (next-window))
  191.       (while (eq t
  192.              (setq result
  193.                (progn
  194.                  (message "%s: a(dd), c(orrect), r(eplace), space or s(kip) [default], ? (help)" (upcase word)) ; q(uit)
  195.                  (setq char (read-char))
  196.                  (setq num (- char ?0))
  197.                  (cond ((or (= char ? ) (= char ?s))           ; Skip for this invocation
  198.                                     (ispell-ignore-later-occurrences word)
  199.                                     nil)
  200.                    ((= char ?a)                            ; Add to dictionary
  201.                      (send-string ispell-process
  202.                           (concat "*" word "\n"))
  203.                     (send-string ispell-process            ; Because ispell isn't reinitialized
  204.                         (concat "@" word "\n"))
  205.                                     (ispell-ignore-later-occurrences word)
  206.                     nil)
  207.                    ((= char ?c)                           ; Assume correct but don't add to dict
  208.                     (send-string ispell-process
  209.                         (concat "@" word "\n"))
  210.                                     (ispell-ignore-later-occurrences word)
  211.                     nil)
  212.                    ((= char ?r)                           ; Query replace
  213.                                     (ispell-ignore-later-occurrences word)
  214.                                     (read-string (format "Replacement for %s: " (upcase word)) nil))
  215.                    ((and (>= num 0) (< num count))
  216.                                     (ispell-ignore-later-occurrences word)
  217.                                     (nth num choices))
  218.                    ((= char ?\C-r)                        ; Note: does not reset syntax table
  219.                     (save-excursion (recursive-edit)) t)  ; Dangerous
  220. ;                   ((= char ?\C-z)
  221. ;                    (suspend-emacs) t)
  222.                    ((or (= char help-char) (= char ?\?))
  223.                                     (message "a(dd to dict), c(orrect for this session), r(eplace with your word), or number of replacement")
  224.                     (sit-for 3) t)
  225.                    (t (ding) t))))))
  226.       result))
  227.     ;; Protected forms...
  228.     (bury-buffer "*Choices*")))
  229.  
  230. (defun ispell-ignore-later-occurrences (word)
  231.    (if (get-buffer ispell-temp-name)
  232.        (save-excursion
  233.           (set-buffer ispell-temp-name)
  234.           (save-excursion
  235.              (replace-regexp (concat "^" word "$")
  236.                              (concat "+" word))))))
  237.  
  238. (defun overlay-window (height)
  239.   "Create a (usually small) window with HEIGHT lines and avoid
  240. recentering."
  241.   (save-excursion
  242.     (let ((oldot (save-excursion (beginning-of-line) (dot)))
  243.       (top (save-excursion (move-to-window-line height) (dot)))
  244.       newin)
  245.       (if (< oldot top) (setq top oldot))
  246.       (setq newin (split-window-vertically height))
  247.       (set-window-start newin top))))
  248.  
  249.  
  250. (defvar ispell-process nil
  251.   "Holds the process object for 'ispell'")
  252.  
  253. (defun ispell-parse-output (output)
  254. "Parse the OUTPUT string of 'ispell' and return either t for an exact
  255. match, a string containing the root word for a match via suffix
  256. removal, a list of possible correct spellings, or nil for a complete
  257. miss."
  258.   (cond
  259.    ((string= output "*") t)
  260.    ((string= output "#") nil)
  261.    ((string= (substring output 0 1) "+")
  262.     (substring output 2))
  263.    (t
  264.     (let ((choice-list '()))
  265.       (while (not (string= output ""))
  266.     (let* ((start (string-match "[A-z]" output))
  267.            (end (string-match " \\|$" output start)))
  268.       (if start
  269.           (setq choice-list (cons (substring output start end)
  270.                       choice-list)))
  271.       (setq output (substring output (1+ end)))))
  272.       choice-list))))
  273.  
  274.  
  275. (defun ispell-init-process ()
  276.    "Check status of 'ispell' process and start if necessary."
  277.    (if (and ispell-process
  278.             (eq (process-status ispell-process) 'run))
  279.        (save-excursion
  280.           (set-buffer ispell-out-name)
  281.           (erase-buffer))
  282.        (message "Starting new ispell process...")
  283.        (and (get-buffer ispell-out-name) (kill-buffer ispell-out-name))
  284.        (setq ispell-process (apply 'start-process "ispell"
  285.                                    ispell-out-name ispell-program-name
  286.                                    (if ispell-dictionary
  287.                                        (list "-p" ispell-dictionary "-A")
  288.                                        (list "-A"))))
  289.        (process-kill-without-query ispell-process)
  290.        (sit-for 3)))
  291.  
  292. ; For TeX users, try "detex -iw" or "detex -iw | tr -cs A-Za-z \012".  Note
  293. ; that the output of the filter must be one word per line.
  294.  
  295. (defvar ispell-filter-hook "tr"
  296.   "Filter to pass a region through before sending it to ispell.
  297. Must produce output one word per line.  Typically this is set to tr,
  298. deroff, detex, etc.")
  299. (make-variable-buffer-local 'ispell-filter-hook)
  300.  
  301. (defvar ispell-filter-hook-args '("-cs" "A-Za-z" "\012")
  302.   "Argument LIST to pass to ispell-filter-hook")
  303. (make-variable-buffer-local 'ispell-filter-hook-args)
  304.  
  305. ; This routine has certain limitations brought about by the filter
  306. ; hook.  For example, deroff will take ``\fBcat\fR'' and spit out
  307. ; ``cat''.  This is hard to search for since word-search-forward will
  308. ; not match at all and search-forward for ``cat'' will match
  309. ; ``concatenate'' if it happens to occur before.
  310. ; `ispell-region' filters the region into `*ispell-temp*', writes the
  311. ; buffer to a temporary file, and sends a ``&Include_File&foobar''
  312. ; string to the ispell process which is writing into `*ispell*'.
  313. ; `ispell-region' then searches `*ispell*' for a spelling error (`#' or
  314. ; `&'), checks the `*ispell-temp*' buffer for the misspelled word and
  315. ; then skips forward `count' words (the number of correct lines in
  316. ; `*ispell*') in the region.  It then searches for the misspelled
  317. ; word.  This is not a foolproof heuristic but it is fast and works
  318. ; most of the time.
  319. ; ... with the unfortunate side-effect that it will sometimes
  320. ; pick up the same string in other words too (e.g. if you had the word "food"
  321. ; near the "\fIfoo\fP" that you were looking for).
  322. ; Another disadvantage is that your "prefobnicator" (deroff or detex or
  323. ; whatever) can't delete too many words (and you can't run it through spell(1)
  324. ; to cut down on the number of words you want checked) because of the way this
  325. ; hack works.
  326. ; To get around this, you can setq the variable ispell-words-have-boundaries to
  327. ; t (for normal cases) and nil (for embedded-word texts such as for nroff/troff).
  328. ; In the first case, your prefobnicator can, for instance, do a "ispell -l" to cut
  329. ; down on the number of words you need to "ispell -a" (increasing the program's
  330. ; speed considerably).
  331.  
  332. (defun ispell-region (start end)
  333.    "Check a region for spelling errors interactively.  The variable
  334. which should be buffer or mode specific ispell-filter-hook is called
  335. to filter out text processing commands."
  336.    (interactive "r")
  337.    (let ((this-buf (current-buffer))
  338.          (spell-file (make-temp-name "/tmp/ispell"))
  339.          (spell-buf (get-buffer-create ispell-temp-name))
  340.          (current-syntax (syntax-table))
  341.          (tracker 1)
  342.          word poss replace endbound ispell-out)
  343.       (ispell-init-process)
  344.       (setq ispell-out (get-buffer ispell-out-name))
  345.       (unwind-protect
  346.          (save-excursion
  347.             (save-restriction
  348.                (message "Prefrobnicating...")
  349.                (narrow-to-region start end)
  350.                (sit-for 0)
  351.                (set-syntax-table ispell-syntax-table)
  352.                (set-buffer spell-buf)
  353.                (erase-buffer)
  354.                (set-buffer this-buf)
  355.                (apply 'call-process-region 
  356.                       (append (list start end ispell-filter-hook nil spell-buf nil)
  357.                               ispell-filter-hook-args))
  358.                (goto-char start)
  359.                (set-buffer spell-buf)
  360.                (and (/= (preceding-char) ?\n) ; couple of hacks for tr
  361.                     (insert "\n"))
  362.                (goto-char (point-min))
  363.                (while (= (following-char) ?\n)
  364.                   (delete-char 1))
  365.                (write-region (point-min) (point-max) spell-file nil 1)
  366.                (send-string ispell-process 
  367.                             (concat "&Include_File&" spell-file "\n"))
  368.                (message "Looking for a misspelled word... (status: %s)" (process-status ispell-process))
  369.                (sit-for 0)
  370.                (while (and (not (eobp))
  371.                            (eq (process-status ispell-process) 'run))
  372.                   (set-buffer ispell-out)
  373.                   (goto-char (point-max))
  374.                   (beginning-of-line)
  375.                   (setq endbound (point))
  376.                   (goto-char tracker)
  377.                   (if (prog1
  378.                          (not (re-search-forward "^[#&]" endbound 1))
  379.                          (beginning-of-line)
  380.                          (setq count (count-lines tracker (point))
  381.                                tracker (point))
  382.                          (set-buffer spell-buf)
  383.                          (forward-line count)
  384.                          (message "Looking for a misspelled word... (status: %s)"  ;; "(status: %s, at: %s, #%s)"
  385.                                   (process-status ispell-process)
  386. ;;                                (upcase (buffer-substring (point) (save-excursion (end-of-line) (point))))
  387. ;;                                (count-lines (point-min) (point))
  388.                                   ))
  389.                      (prog1
  390.                          (accept-process-output) ; Give it some time to get something
  391.                          (sit-for 2))            ; Don't hog all the time
  392.                       (setq word (buffer-substring (point)
  393.                                                    (progn (end-of-line) (point))))
  394.                       (forward-char 1)
  395.                       (set-buffer ispell-out) ; (goto-char tracker)
  396.                       (setq poss (ispell-parse-output
  397.                                   (buffer-substring (point) 
  398.                                                     (progn (end-of-line) (point)))))
  399.                       (forward-char 1)
  400.                       (setq tracker (point))
  401.                       (set-buffer this-buf)
  402.                       (re-search-forward "\\W*\\(\\w+\\)" nil t (1- count)) ; get close
  403.                       (if (string= "+" (substring word 0 1))
  404.                           (search-forward (substring word 1) nil t)
  405.                           (if (re-search-forward (if ispell-words-have-boundaries
  406.                                                   (concat "\\b" (regexp-quote word) "\\b")
  407.                                                   (regexp-quote word))
  408.                                                  nil t)
  409.                               (let ((end (point)))
  410.                                  (search-backward word nil t)
  411.                                  (save-excursion
  412.                                     (let ((start (point)))
  413.                                        (recenter (/ (window-height) 2)) ; show word in context
  414.                                        (sit-for 0)
  415. ;;                                     (highlight-region start end)
  416.                                        (setq replace (ispell-choose poss word))
  417. ;;                                     (unhighlight-region start end)
  418.                                        ))
  419.                                  (if replace
  420.                                      (save-excursion
  421.                                         (query-replace-regexp (if ispell-words-have-boundaries
  422.                                                                   (concat "\\b" (regexp-quote word) "\\b")
  423.                                                                   (regexp-quote word))
  424.                                                               replace))))
  425.                               (message "Can't find %s in original text -- Any key to continue" word)
  426.                               (read-char)
  427. ;;                            (and (= ?\C-z (read-char)) (suspend-emacs))
  428.                               )
  429.                           (message "Looking for a misspelled word... (status: %s)" (process-status ispell-process))
  430.                           (sit-for 0))
  431.                       (set-buffer spell-buf)))))
  432.          (if (eq (process-status ispell-process) 'run)
  433.              (message "Done.")
  434.              (message "Warning - ispell process died."))
  435.          (set-syntax-table current-syntax)
  436.          (and (file-exists-p spell-file)
  437.               (delete-file spell-file)))))
  438.  
  439. (defun ispell-buffer () 
  440.   "Check the current buffer for spelling errors interactively.  The variable
  441. which should be buffer or mode specific ispell-filter-hook is called to
  442. filter out text processing commands."
  443.   (interactive)
  444.   (ispell-region (point-min) (point-max)))
  445.  
  446.  
  447. ; In case you don't have this, uncomment the following:
  448.  
  449. ; (defun highlight-region (p1 p2)
  450. ;    "Highlight the current region."
  451. ;    (interactive "r")
  452. ;    (let ((s (buffer-substring p1 p2))
  453. ;          (inverse-video t))
  454. ;       (delete-region p1 p2)
  455. ;       (sit-for 0)
  456. ;       (insert s)
  457. ;       (sit-for 0)))
  458.  
  459. ; (defun unhighlight-region (p1 p2)
  460. ;    "Unhighlight the current region."
  461. ;    (interactive "r")
  462. ;    (let ((s (buffer-substring p1 p2))
  463. ;          (inverse-video nil))
  464. ;       (delete-region p1 p2)
  465. ;       (sit-for 0)
  466. ;       (insert s)
  467. ;       (sit-for 0)))
  468.  
  469.  
  470. ;; Interactive word completion.
  471. ;; Some code and many ideas tweaked from Peterson's spell-dict.el.
  472. ;; Ashwin Ram <Ram@yale>, 8/14/87.
  473.  
  474. (defvar ispell-words-file "/usr/dict/words"
  475.    "*File used for ispell-complete-word command.  On 4.3bsd systems, try
  476. using \"/usr/dict/web2\" for a larger selection.  Apollo users may want to
  477. try \"/sys/dict\".")
  478.  
  479. (defun ispell-complete-word ()
  480.    "Look up word before point in dictionary (see the variable
  481. ispell-words-file) and try to complete it.  If in the middle of a word,
  482. replace the entire word."
  483.    (interactive)
  484.    (let* ((current-word (buffer-substring (save-excursion (backward-word 1) (point))
  485.                                           (point)))
  486.           (in-word (looking-at "\\w"))
  487.           (possibilities (save-excursion
  488.                             (set-buffer (get-buffer-create ispell-temp-name))
  489.                             (erase-buffer)
  490.                             (call-process "look" nil t nil "-df" current-word ispell-words-file)
  491.                             (if (> (buffer-size ) 0)
  492.                                 (ispell-parse-output (buffer-string))
  493.                                 '())))
  494.           (replacement (ispell-choose possibilities current-word)))
  495.       (cond (replacement
  496.              (if in-word (kill-word 1))        ;; Replace the whole word.
  497.              (search-backward current-word)
  498.              (replace-match replacement)))))   ;; To preserve capitalization etc.
  499.  
  500.