;;; Time-stamp: <94/01/30 00:24:27 john>

;; Hacks to go on top of the main emacs spell.el

(defvar spelling-corrections nil
  "A list of the corrections made, in the form of an alist car:old cdr:new.")

(defvar spelling-non-corrections nil
  "A list of the corrections not made, in the form of a list of strings.
These are the possible corrections that the user has declined to make.
The list is used to stop them being offered again.")

(defun spell-region (start end &optional description)
  "Like spell-buffer but applies only to region.
Used in a program, applies from START to END.
DESCRIPTION is an optional string naming the unit being checked:
for example, \"word\"."
  (interactive "r")
  (let ((filter spell-filter)
	(buf (get-buffer-create " *temp*")))
    (save-excursion
      (set-buffer buf)
      (widen)
      (erase-buffer))
    (message "Checking spelling of %s..." (or description "region"))
    (if (and (null filter) (= ?\n (char-after (1- end))))
	(if (string= "spell" spell-command)
	    (call-process-region start end "spell" nil buf)
	  (call-process-region start end shell-file-name
			       nil buf nil "-c" spell-command))
      (let ((oldbuf (current-buffer)))
	(save-excursion
	  (set-buffer buf)
	  (insert-buffer-substring oldbuf start end)
	  (or (bolp) (insert ?\n))
	  (if filter (funcall filter))
	  (if (string= "spell" spell-command)
	      (call-process-region (point-min) (point-max) "spell" t buf)
	    (call-process-region (point-min) (point-max) shell-file-name
				 t buf nil "-c" spell-command)))))
    (message "Checking spelling of %s...%s"
	     (or description "region")
	     (if (save-excursion
		   (set-buffer buf)
		   (> (buffer-size) 0))
		 "not correct"
	       "correct"))
    (let (word newword
	       (main-buf (current-buffer))
	       (case-fold-search t)
	       (case-replace t))
      (while (save-excursion
	       (set-buffer buf)
	       (> (buffer-size) 0))
	(save-excursion
	  (set-buffer buf)
	  (goto-char (point-min))
	  (setq word (downcase
		      (buffer-substring (point)
					(progn (end-of-line) (point)))))
	  (forward-char 1)
	  (delete-region (point-min) (point))
	  (if  (string-memberp word spelling-non-corrections)
	      (setq newword word)
	    (let ((poss-new-word (assoc word spelling-corrections)))
	      (setq poss-new-word
		    (if poss-new-word (cdr poss-new-word) word))
	      (spell-hack-display-word-nicely word main-buf)
	      (setq newword
		    (read-input (concat "`" word
					"' not recognized; edit a replacement: ")
				poss-new-word))))
	  (flush-lines (concat "^" (regexp-quote word) "$")))
	(if (equal word newword)
	    (setq spelling-non-corrections (cons word spelling-non-corrections))
	  (progn
	    (setq spelling-corrections (cons (cons word newword)
					     spelling-corrections))
	    (goto-char (point-min))
	    (query-replace-regexp (concat "\\b" (regexp-quote word) "\\b")
				  newword)))))))


(defun spell-hack-display-word-nicely (word buf)
  (save-excursion
    (set-buffer buf)
    (goto-char (point-min))
    (if (re-search-forward (concat "\\b" (regexp-quote word) "\\b")
			   (point-max)
			   t)
	(with-output-to-temp-buffer "*Word context*"
	  (princ (buffer-substring (max (point-min) (- (match-beginning 0) 100))
				   (min (point-max) (+ (match-end 0) 100))))))))

;;; end of startup/spell.el