Otherware/Otherware_1_SB_Development.iso/amiga/utility/text/ispell.lha/ispell.el

Text File | 1992-07-04 | 15.7 KB | 431 lines

;;; Spelling correction interface for GNU EMACS using "ispell".

;;; This file is not part of the GNU Emacs distribution (yet).

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; this file, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

(provide 'ispell)

;;; MODIFICATION HISTORY:

;;; Steve Koren   - AmigaDos specific version to use ispell's ARexx port.
;;;                 needs: ISpell version 3.1ljr with ARexx Server mode.
;;;                 ispell must be in the AmigaDos search path.   This
;;;                 version no longer works under Unix.
;;;
;;;                 Binds \M-$ to ispell-word
;;;                 Binds \M-* to ispell-complete-word

;;; Ashwin Ram      ARPA:    [e-mail]
;;;                 UUCP:    ...!{decvax, linus, seismo}!yale!Ram-Ashwin
;;;                 BITNET:  Ram@yalecs
;;; Added variable to control embedded word checking (nice in troff but a pain otherwise).
;;; 10/26/87.
;;; Interactive word completion.
;;; 8/14/87.
;;; Detex before checking spelling.
;;; Made options more mnemonic, prompt and error messages better.
;;; Added highlighting of misspelled word.
;;; Query-replace all occurrences of misspelled word through buffer.
;;; Allow customization of personal dictionary.
;;; Moved temporary file to /tmp.
;;; Added check for dead ispell process to avoid infinite loop.
;;; Avoid repeated querying for same word in same buffer.
;;; 7/6/87.

;;; Walt Buehring
;;; Texas Instruments - Computer Science Center
;;; ARPA:  Buehring%TI-CSL@CSNet-Relay
;;; UUCP:  {smu, texsun, im4u, rice} ! ti-csl ! buehring

;;; ispell-region and associated routines added by
;;; Perry Smith
;;; pedz@bobkat
;;; Tue Jan 13 20:18:02 CST 1987

;;; extensively modified by Mark Davies and Andrew Vignaux
;;; {mark,andrew}@vuwcomp
;;; Sun May 10 11:45:04 NZST 1987

;;; Depends on the ispell program snarfed from MIT-PREP in early 1986.

;;; To fully install this, add this file to your GNU lisp directory and
;;; compile it with M-X byte-compile-file.  Then add the following to the
;;; appropriate init file:
;;;
;;; (autoload 'ispell-word "ispell" "Check spelling of word at or before point" t)
;;; (autoload 'ispell-complete-word "ispell" "Complete word at or before point" t)
;;; (autoload 'ispell-region "ispell" "Check spelling of every word in the region" t)
;;; (autoload 'ispell-buffer "ispell" "Check spelling of every word in the buffer" t)
;;; You might want to bind ispell-word and ispell-complete word to keys.

;;; If run on a heavily loaded system, the initial sleep time in
;;; ispell-init-process may need to be increased.

(define-key global-map "\M-$" 'ispell-word)
(define-key global-map "\M-*" 'ispell-complete-word)

(defconst ispell-temp-name " *ispell-temp*"
  "Name of the temporary buffer that 'ispell-region' uses to hold the
filtered region")

(defvar ispell-words-have-boundaries t
   "If nil, a misspelled word matches embedded words too.  This is useful in
nroff/troff, where a misspelled word may be hidded (e.g., \fIword\fB), and a
pain otherwise.")

(defvar ispell-syntax-table nil)

(defvar ispell-temp-words ",")

(if (null ispell-syntax-table)
    ;; The following assumes that the standard-syntax-table
    ;; is static.  If you add words with funky characters
    ;; to your dictionary, the following may have to change.
    (progn
      (setq ispell-syntax-table (make-syntax-table))
      ;; Make certain characters word constituents
      ;; (modify-syntax-entry ?' "w   " ispell-syntax-table)
      ;; (modify-syntax-entry ?- "w   " ispell-syntax-table)
      ;; Get rid on existing word syntax on certain characters
      (modify-syntax-entry ?0 ".   " ispell-syntax-table)
      (modify-syntax-entry ?1 ".   " ispell-syntax-table)
      (modify-syntax-entry ?2 ".   " ispell-syntax-table)
      (modify-syntax-entry ?3 ".   " ispell-syntax-table)
      (modify-syntax-entry ?4 ".   " ispell-syntax-table)
      (modify-syntax-entry ?5 ".   " ispell-syntax-table)
      (modify-syntax-entry ?6 ".   " ispell-syntax-table)
      (modify-syntax-entry ?7 ".   " ispell-syntax-table)
      (modify-syntax-entry ?8 ".   " ispell-syntax-table)
      (modify-syntax-entry ?9 ".   " ispell-syntax-table)
      (modify-syntax-entry ?$ ".   " ispell-syntax-table)
      (modify-syntax-entry ?% ".   " ispell-syntax-table)))


(defun ispell-word (&optional quietly noclear)
   "Check spelling of word at or before dot.
If word not found in dictionary, display possible corrections in a window
and let user select."
   (interactive)
   (let* ((current-syntax (syntax-table))
          start end word poss replace)
      (unwind-protect
            (save-excursion
               (set-syntax-table ispell-syntax-table)            ;; Ensure syntax table is reasonable
               (if (not (looking-at "\\w"))
                   (re-search-backward "\\w" (point-min) 'stay)) ;; Move backward for word if not already on one
               (re-search-backward "\\W" (point-min) 'stay)      ;; Move to start of word
               (or (re-search-forward "\\w+" nil t)              ;; Find start and end of word
                   (error "No word to check."))
               (setq start (match-beginning 0)
                     end (match-end 0)
                     word (buffer-substring start end)))
         (set-syntax-table current-syntax))
      (ispell-init-process)   ;; erases ispell output buffer
      (or noclear (ispell-clear-ignore-list))

      (or quietly (message "Checking spelling of %s..." (upcase word)))

      (if (string-match (concat "," word ",") ispell-temp-words)
          (setq poss "*")

        (setq poss (ispell-parse-output (amiga-ispell-lookup word)))
      )

      (cond ((eq poss t)
             (or quietly (message "Checking spelling of %s... correct" (upcase word))))
            ((stringp poss)
             (or quietly (message "Checking spelling of %s... correct (derived from %s)" (upcase word) (upcase poss))))
;           ((null poss)
;            (or quietly (message "Checking spelling of %s... not found" (upcase word))))
            (t (setq replace (ispell-choose poss word))
               (if replace
                   (progn
                      (goto-char end)
                      (delete-region start end)
                      (insert-string replace)))))
      poss))


(defun ispell-choose (choices word)
  "Display possible corrections from list CHOICES.  Return chosen word
if one is chosen, or nil to keep original WORD."
  (unwind-protect
      (save-window-excursion
    (let ((count 0)
          (line 2)
          (words choices)
          (window-min-height 2)
          char num result)
      (save-excursion
        (set-buffer (get-buffer-create "*Choices*")) (erase-buffer)
        (setq mode-line-format (concat "--  %b (Type number to select replacement for "
                                           (upcase word)
                                           ")  --"))
        (while words
          (if (<= (+ 7 (current-column) (length (car words)))
              (window-width))
          nil
        (insert "\n")
        (setq line (1+ line)))
          (insert "(" (+ count ?0) ") " (car words) "  ")
          (setq words (cdr words)
            count (1+ count)))
            (if (= count 0) (insert "(none)")))
      (overlay-window line)
      (switch-to-buffer "*Choices*")
      (select-window (next-window))
      (while (eq t
             (setq result
               (progn
                 (message "%s: a(dd), c(orrect), r(eplace), space or s(kip) [default], ? (help)" (upcase word)) ; q(uit)
                 (setq char (read-char))
                 (setq num (- char ?0))
                 (cond ((or (= char ? ) (= char ?s))           ; Skip for this invocation
                                    (ispell-ignore-later-occurrences word)
                                    nil)
                   ((= char ?a)                            ; Add to dictionary
                     (amiga-ispell-add word)
                                    (ispell-ignore-later-occurrences word)
                    nil)
                   ((= char ?c)                           ; Assume correct but don't add to dict
                                    (ispell-ignore-later-occurrences word)
                    nil)
                   ((= char ?r)                           ; Query replace
                                    (ispell-ignore-later-occurrences word)
                                    (read-string (format "Replacement for %s: " (upcase word)) nil))
                   ((and (>= num 0) (< num count))
                                    (ispell-ignore-later-occurrences word)
                                    (nth num choices))
                   ((= char ?\C-r)                        ; Note: does not reset syntax table
                    (save-excursion (recursive-edit)) t)  ; Dangerous
;                   ((= char ?\C-z)
;                    (suspend-emacs) t)
                   ((or (= char help-char) (= char ?\?))
                                    (message "a(dd to dict), c(orrect for this session), r(eplace with your word), or number of replacement")
                    (sit-for 3) t)
                   (t (ding) t))))))
      result))
    ;; Protected forms...
    (bury-buffer "*Choices*")))

(defun ispell-clear-ignore-list ()
  (setq ispell-temp-words ",")
)

(defun ispell-ignore-later-occurrences (word)

  (if (not (string-match (concat "," word ",") ispell-temp-words))
      (setq ispell-temp-words
            (concat ispell-temp-words word ",")))
)

(defun overlay-window (height)
  "Create a (usually small) window with HEIGHT lines and avoid
recentering."
  (save-excursion
    (let ((oldot (save-excursion (beginning-of-line) (dot)))
      (top (save-excursion (move-to-window-line height) (dot)))
      newin)
      (if (< oldot top) (setq top oldot))
      (setq newin (split-window-vertically height))
      (set-window-start newin top))))


(defun ispell-parse-output (output)
"Parse the OUTPUT string of 'ispell' and return either t for an exact
match, a string containing the root word for a match via suffix
removal, a list of possible correct spellings, or nil for a complete
miss."
  (cond
   ((string= output "*\n") t)
   ((string= output "#\n") nil)
   ((string= (substring output 0 1) "+")
    (substring output 2))
   (t
    (let ((choice-list '()))
      (while (not (string= output ""))
    (let* ((start (string-match "[A-z]" output))
           (end (string-match " \\|$" output start)))
      (if start
          (setq choice-list (cons (substring output start end)
                      choice-list)))
      (setq output (substring output (1+ end)))))
      choice-list))))


(defun ispell-init-process ()
   "Check status of 'ispell' process and start if necessary."

   (if (not (boundp 'amiga-ispell-initialized))

       (progn
         (message "starting ispell...")
         (amiga-arexx-do-command
          (concat

"\"if pos('IRexxSpell', (show(ports))) = 0 then do;
address command 'run ispell -r <nil: >nil:';
address command waitforport 'IRexxSpell';
end\"") nil

         )
         (setq amiga-ispell-initialized t)
       )
   )
)

(defvar ispell-filter-hook "tr"
  "Filter to pass a region through before sending it to ispell.
Must produce output one word per line.  Typically this is set to tr,
deroff, detex, etc.")
(make-variable-buffer-local 'ispell-filter-hook)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OLD CODE:
;;(defvar ispell-filter-hook-args '("-cs" "A-Za-z" "\012")
;;  "Argument LIST to pass to ispell-filter-hook")
;;(make-variable-buffer-local 'ispell-filter-hook-args)
;;
;; NEW CODE:
(defvar ispell-filter-hook-args
  (if (equal system-type 'hpux)
      '("-cs" "[A-Z][a-z]" "[\012*]")
      '("-cs" "A-Za-z" "\n")
  )
  "Argument LIST to pass to ispell-filter-hook"
)
(make-variable-buffer-local 'ispell-filter-hook-args)


(defun ispell-region (start end)
   "Check a region for spelling errors interactively.  The variable
which should be buffer or mode specific ispell-filter-hook is called
to filter out text processing commands."
   (interactive "r")
   (let ((current-syntax (syntax-table)))
     (ispell-clear-ignore-list)
     (ispell-init-process)

     (unwind-protect
         (save-excursion
           (save-restriction
             (message "Prefrobnicating...")
             (narrow-to-region start end)
             (sit-for 0)
             (set-syntax-table ispell-syntax-table)

             (goto-char start)

             (message "Looking for a misspelled word...")

             (while (forward-word 1)
               (if (equal (ispell-word t t) t)
                   (message "Looking for a misspelled word...")
               )
             )

             (sit-for 0)

             (message "Done.")

             (set-syntax-table current-syntax))))))

(defun ispell-buffer ()
  "Check the current buffer for spelling errors interactively.  The variable
which should be buffer or mode specific ispell-filter-hook is called to
filter out text processing commands."
  (interactive)
  (ispell-region (point-min) (point-max)))


; In case you don't have this, uncomment the following:

; (defun highlight-region (p1 p2)
;    "Highlight the current region."
;    (interactive "r")
;    (let ((s (buffer-substring p1 p2))
;          (inverse-video t))
;       (delete-region p1 p2)
;       (sit-for 0)
;       (insert s)
;       (sit-for 0)))

; (defun unhighlight-region (p1 p2)
;    "Unhighlight the current region."
;    (interactive "r")
;    (let ((s (buffer-substring p1 p2))
;          (inverse-video nil))
;       (delete-region p1 p2)
;       (sit-for 0)
;       (insert s)
;       (sit-for 0)))


;; Interactive word completion.
;; Some code and many ideas tweaked from Peterson's spell-dict.el.
;; Ashwin Ram <Ram@yale>, 8/14/87.

(defun ispell-complete-word ()
   "Look up word before point in dictionary (see the variable
ispell-words-file) and try to complete it.  If in the middle of a word,
replace the entire word."
   (interactive)
   (let* ((current-word (buffer-substring (save-excursion (backward-word 1) (point))
                                          (point)))
          (in-word (looking-at "\\w"))
          (words (if (> (length current-word) 2)
                     (amiga-ispell-lookup
                      (concat current-word ".*") t)
                   ""))

          (possibilities (if (> (length words) 0)
                             (ispell-parse-output words)
                                '()))

     (replacement (ispell-choose possibilities current-word)))
   (cond (replacement
          (if in-word (kill-word 1))        ;; Replace the whole word.
          (search-backward current-word)
          (replace-match (downcase replacement))))))   ;; To preserve capitalization etc.


;;; **************************************************************************
;;; --- Amiga specific extension to ispell to use ispell's ARexx port --------
;;; **************************************************************************

(defun amiga-ispell-lookup (word &optional regexp)
  "lookup word in dictionary using arexx - interal ispell fn"
  (amiga-arexx-do-command
   (concat

    "\"options results;
       address 'IRexxSpell' " (if regexp "lookup" "check") " '"
    word
    "' ;address EMACS1 '(setq arexx-result '||d2c(34)||result||d2c(34)||')'\""
    )
   nil)

  (concat arexx-result "\n")
)

(defun amiga-ispell-add (word)
  "add word to dictionary using arexx - interal ispell fn"
  (amiga-arexx-do-command
   (concat "\"address 'IRexxSpell' 'add' '" word "'")
   nil)
)