Archived
1
0
Fork 0
This repository has been archived on 2024-10-19. You can view files and clone it, but cannot push or open issues or pull requests.
emacs/code/elpa/flyspell-correct-20220520.630/flyspell-correct.el

547 lines
21 KiB
EmacsLisp
Raw Normal View History

2022-08-26 00:05:35 +00:00
;;; flyspell-correct.el --- Correcting words with flyspell via custom interface -*- lexical-binding: t; -*-
;;
;; Copyright (c) 2016-2022 Boris Buliga
;;
;; Author: Boris Buliga <boris@d12frosted.io>
;; URL: https://github.com/d12frosted/flyspell-correct
;; Version: 0.6.1
;; Package-Requires: ((emacs "24"))
;;
;; This file is not part of GNU Emacs.
;;
;;; License: GPLv3
;;
;;; Commentary:
;;
;; This package provides functionality for correcting words via custom
;; interfaces. There are several functions for this:
;;
;; - `flyspell-correct-at-point' - to correct word at point.
;; - `flyspell-correct-previous' to correct any visible word before the point.
;; - `flyspell-correct-next' to correct any visible word after the point.
;; - `flyspell-correct-wrapper' - a beefed wrapper for
;; `flyspell-correct-previous' and `flyspell-correct-next' allowing one to
;; correct many words at once (rapid flow) and change correction direction.
;;
;; In most cases the last function is the most convenient, so don't forget to
;; bind it.
;;
;; (define-key flyspell-mode-map (kbd "C-;") 'flyspell-correct-wrapper)
;;
;; When invoked, it will show the list of corrections suggested by Flyspell.
;;
;; Most interfaces also allow you to save the new word to your dictionary,
;; accept this spelling in current buffer or for a whole session, or even skip
;; this word (useful in a rapid flow).
;;
;; Default interface is implemented using `completing-read', but it's highly
;; advised to use `flyspell-correct-ido' (which comes bundled with this package)
;; or any interface provided by following packages: `flyspell-correct-ivy',
;; `flyspell-correct-helm' and `flyspell-correct-popup'.
;;
;; In order to use `flyspell-correct-ido' interface instead of default
;; `flyspell-correct-completing-read', place following snippet in your
;; 'init.el' file.
;;
;; (require 'flyspell-correct-ido)
;;
;; It's easy to implement your own interface for `flyspell-correct'. Checkout
;; documentation for `flyspell-correct-interface' variable.
;;
;; For more information about this and related packages, please refer to
;; attached README.org file.
;;
;;; Code:
;;
;; Requires
(require 'flyspell)
;; Variables
(defcustom flyspell-correct-interface #'flyspell-correct-completing-read
"Interface for `flyspell-correct-at-point'.
`flyspell-correct-interface' is a function accepting two arguments:
- candidates for correction (list of strings)
- misspelled word (string)
Result must be either a string (replacement word) or a cons of a
command and a string (replacement word), where the command is one
of the following:
- skip - do nothing to misspelled word, in rapid mode used for
jumping to the next (or previous) misspelled word
- break - do nothing to misspelled word, break from rapid mode
- stop - do nothing to misspelled word, break from rapid
mode (if enabled) and leave the point at the misspelled word
- save - replace misspelled word with replacement word and save
it to the personal dictionary
- session - replace misspelled word with replacement word and
save it to the session dictionary (correction will be
discarded upon quitting Emacs)
- buffer - replace misspelled word with replacement word and
save it to the buffer dictionary (added to the bottom of
buffer)"
:group 'flyspell-correct
:type 'function)
(defcustom flyspell-correct-highlight t
"When non-nil highlight the word while correcting.
The face `flyspell-correct-highlight-face' is used for
highlighting."
:group 'flyspell-correct
:type 'boolean)
(defface flyspell-correct-highlight-face
'((t (:inherit isearch)))
"Face used for highlighting the word while correcting."
:group 'flyspell-correct)
(defvar flyspell-correct-overlay nil)
;;; Default interface using `completing-read'
;;
(defvar flyspell-correct--cr-key "@"
"Shortcut key used by `flyspell-correct-completing-read'.")
(defvar flyspell-correct--cr-actions
'((save ?s "[Save]")
(session ?a "[Accept (session)]")
(buffer ?b "[Accept (buffer)]")
(skip ?k "[Skip]")
(stop ?p "[Stop]"))
"Actions used by `flyspell-correct-completing-read'.")
(defun flyspell-correct--cr-index (n)
"Generate a short unique index string for N.
The index string is used to prefix suggestion candidates. The digits 12345
encode (mod n 5) and occur as suffix of the index string. If one of the keys
12345 is pressed, the selected candidate is automatically submitted. The
remaining value (/ n 5) is encoded using the digits 67890, which occur in the
prefix of the index string."
(let ((str (char-to-string (+ ?1 (mod n 5)))))
(when (>= n 5)
(setq n (/ (- n 5) 5))
(while (>= n 0)
(setq str (format "%c%s" (aref "67890" (mod n 5)) str)
n (1- (/ n 5)))))
str))
(defun flyspell-correct-completing-read (candidates word)
"Run `completing-read' for the given CANDIDATES.
List of CANDIDATES is given by flyspell for the WORD.
Return a selected word to use as a replacement or a tuple
of (command, word) to be used by `flyspell-do-correct'."
(let* ((idx 0)
(candidates-alist
(append
(mapcar (lambda (cand)
(prog1
(cons (concat
(propertize (flyspell-correct--cr-index idx) 'face 'minibuffer-prompt)
" " cand)
cand)
(setq idx (1+ idx))))
candidates)
(mapcar
(pcase-lambda (`(,name ,key ,label))
(setq key (char-to-string key))
(cons (concat (propertize (format "%s%s " flyspell-correct--cr-key key) 'invisible t)
(replace-regexp-in-string
key (propertize key 'face '(bold minibuffer-prompt))
(propertize label 'face 'minibuffer-prompt)))
(cons name word)))
flyspell-correct--cr-actions)))
(suggestions-title (format "Suggestions (Dictionary \"%s\")"
(or ispell-local-dictionary
ispell-dictionary
"default")))
(actions-title (format "Actions (Shortcut key %s)" flyspell-correct--cr-key))
(metadata `(metadata
(category . flyspell)
(display-sort-function . ,#'identity)
(cycle-sort-function . ,#'identity)
(group-function
. ,(lambda (cand transform)
(cond
(transform cand)
((string-prefix-p flyspell-correct--cr-key cand) actions-title)
(t suggestions-title))))))
(quick-result)
(result
(minibuffer-with-setup-hook
(lambda ()
(add-hook 'post-command-hook
(lambda ()
;; Exit directly if a quick key is pressed
(let ((prefix (concat (minibuffer-contents-no-properties) " ")))
(mapc (lambda (cand)
(when (string-prefix-p prefix (car cand))
(setq quick-result (car cand))
(exit-minibuffer)))
candidates-alist)))
-1 'local))
(completing-read
(format "Suggestions for \"%s\": " word)
;; Use function with metadata to disable add a group function
;; and in order to disable sorting.
(lambda (input predicate action)
(if (eq action 'metadata)
metadata
(complete-with-action action candidates-alist input predicate)))
;; Require confirmation, if the input does not match a suggestion
nil 'confirm nil nil
;; Pass the word as default value (effectively skipping)
word))))
(or (cdr (assoc (or quick-result result) candidates-alist)) result)))
(define-obsolete-function-alias
'flyspell-correct-dummy
'flyspell-correct-completing-read
"0.6.1")
;;; On point word correction
;;
;;;###autoload
(defun flyspell-correct-at-point ()
"Correct word before point using `flyspell-correct-interface'.
Adapted from `flyspell-correct-word-before-point'."
(interactive)
(unless flyspell-correct-interface
(error "Could not correct word because `flyspell-correct-interface' is not set"))
(let ((res))
;; use the correct dictionary
(flyspell-accept-buffer-local-defs)
(flyspell-correct--highlight-add)
(unwind-protect
(let ((cursor-location (point))
(word (save-excursion (flyspell-get-word)))
(opoint (point)))
(if (consp word)
(let ((start (nth 1 word))
(end (nth 2 word))
(word (car word))
poss ispell-filter)
;; now check spelling of word.
(ispell-send-string "%\n") ;put in verbose mode
(ispell-send-string (concat "^" word "\n"))
;; wait until ispell has processed word
(while (progn
(accept-process-output ispell-process)
(not (string= "" (car ispell-filter)))))
;; Remove leading empty element
(setq ispell-filter (cdr ispell-filter))
;; ispell process should return something after word is sent.
;; Tag word as valid (i.e., skip) otherwise
(or ispell-filter
(setq ispell-filter '(*)))
(if (consp ispell-filter)
(setq poss (ispell-parse-output (car ispell-filter))))
(cond
((or (eq poss t) (stringp poss))
;; don't correct word
(message "%s is correct" (funcall ispell-format-word-function word))
t)
((null poss)
;; ispell error
(error "Ispell: error in Ispell process"))
(t
;; The word is incorrect, we have to propose a replacement.
(setq res (funcall flyspell-correct-interface (nth 2 poss) word))
;; Some interfaces actually eat 'C-g' so it's impossible to
;; stop rapid mode. So when interface returns nil we treat it
;; as a stop. Fixes #60.
(unless res (setq res (cons 'break word)))
(cond
((stringp res)
(flyspell-do-correct
res poss word cursor-location start end opoint))
(t
(let ((cmd (car res))
(wrd (cdr res)))
(unless (or (eq cmd 'skip)
(eq cmd 'break)
(eq cmd 'stop))
(flyspell-do-correct
cmd poss wrd cursor-location start end opoint)
(unless (string-equal wrd word)
(flyspell-do-correct
wrd poss word cursor-location start end opoint))))))
(ispell-pdict-save t))))))
(flyspell-correct--highlight-remove))
res))
;;; Previous word correction
;;
;;;###autoload
(defun flyspell-correct-previous (position)
"Correct the first misspelled word that occurs before POSITION.
But don't look beyond what's visible on the screen.
Uses `flyspell-correct-at-point' function for correction.
With a prefix argument, automatically continues to all prior misspelled words in the buffer."
(interactive "d")
(flyspell-correct-move position nil current-prefix-arg))
;;; Next word correction
;;
;;;###autoload
(defun flyspell-correct-next (position)
"Correct the first misspelled word that occurs after POSITION.
Uses `flyspell-correct-at-point' function for correction.
With a prefix argument, automatically continues to all further
misspelled words in the buffer."
(interactive "d")
(flyspell-correct-move position t current-prefix-arg))
;;; Generic helpers
;;
;;;###autoload
(defun flyspell-correct-wrapper ()
"Correct spelling error in a dwim fashion based on universal argument.
- One \\[universal-argument] enables rapid mode.
- Two \\[universal-argument]'s changes direction of spelling
errors search.
- Three \\[universal-argument]'s changes direction of spelling
errors search and enables rapid mode."
(interactive)
(let ((forward-direction nil)
(rapid nil))
(cond
((equal current-prefix-arg '(4)) ; C-u = rapid
(setq rapid t))
((equal current-prefix-arg '(16)) ; C-u C-u = change direction
(setq forward-direction t))
((equal current-prefix-arg '(64)) ; C-u C-u C-u = do both
(setq rapid t)
(setq forward-direction t)))
(flyspell-correct-move (point) forward-direction rapid)))
;;;###autoload
(defun flyspell-correct-move (position &optional forward rapid)
"Correct the first misspelled word that occurs before POSITION.
Uses `flyspell-correct-at-point' function for correction.
With FORWARD set non-nil, check forward instead of backward.
With RAPID set non-nil, automatically continues in direction
until all errors in buffer have been addressed."
;; NOTE: The way I may be pushing the mark may possibly be more
;; idiomatically done using the opoint arg of
;; `flyspell-correct-word-before-point'.
(interactive "d")
;; push mark when starting
(when (or (not (mark t))
(/= (mark t) (point)))
(push-mark (point) t))
(let ((original-pos (point))
(target-pos (point))
(hard-move-point)
(mark-opos))
(unwind-protect
(save-excursion
(let ((incorrect-word-pos))
;; narrow the region
(overlay-recenter (point))
(let* ((unsorted-overlay-list
(if forward
(overlays-in (- position 1) (point-max))
(overlays-in (point-min) (+ position 1))))
(comp (if forward #'< #'>))
(overlay-list (sort
unsorted-overlay-list
(lambda (o1 o2)
(funcall comp
(overlay-start o1)
(overlay-start o2)))))
(overlay 'dummy-value))
(while overlay
(setq overlay (car-safe overlay-list))
(setq overlay-list (cdr-safe overlay-list))
(when (and overlay
(flyspell-overlay-p overlay))
(setq incorrect-word-pos (overlay-start overlay))
(let ((scroll (> incorrect-word-pos (window-end))))
(goto-char incorrect-word-pos)
(when scroll (ignore-errors (recenter))))
;; Point originally was on misspelled word, so we need to restore
;; it. This imitates just calling `flyspell-correct-at-point'. But
;; gives all the perks of `flyspell-correct-move'.
;;
;; But with rapid mode, `hard-move-point' will be set to nil
;; eventually. Which gives more predictable point location in
;; general.
(setq hard-move-point
(and (>= original-pos (overlay-start overlay))
(<= original-pos (overlay-end overlay))))
;; Correct a word using `flyspell-correct-at-point'.
(let ((res (flyspell-correct-at-point)))
(when res
;; stop at misspelled word
(when (eq (car-safe res) 'stop)
(setq target-pos incorrect-word-pos
hard-move-point t
mark-opos t))
;; break from rapid mode
(when (or
;; treat skip as one-time rapid mode enabler
(and (not (eq (car-safe res) 'skip))
(not rapid))
;; explicit rapid mode disablers
(eq (car-safe res) 'break)
(eq (car-safe res) 'stop))
(setq overlay nil))
(when (and
;; don't push mark if there is no change
(not (memq (car-safe res) '(stop break skip)))
(/= (mark t) (point)))
;; `flyspell-correct-at-point' may move point, use
;; original `incorrect-word-pos' instead
(push-mark incorrect-word-pos t)))))))))
(when hard-move-point
(when mark-opos
(push-mark (point) t))
(goto-char target-pos))
;; We pushed the mark when starting, but if the operation is canceled
;; without any change that mark is redundant and needs to be cleaned-up.
(when (= (mark t) (point)) (pop-mark)))))
;;; Overlays
(defun flyspell-correct--highlight-add ()
"Highlight the spelling error at point."
(when flyspell-correct-highlight
(let* ((ov (flyspell-correct--overlay-loc))
(ov-start (car-safe ov))
(ov-end (cdr-safe ov)))
(when ov
(if flyspell-correct-overlay
(move-overlay flyspell-correct-overlay ov-start ov-end (current-buffer))
(setq flyspell-correct-overlay (make-overlay ov-start ov-end))
(overlay-put flyspell-correct-overlay 'priority 1001)
(overlay-put flyspell-correct-overlay 'face 'flyspell-correct-highlight-face))))))
(defun flyspell-correct--highlight-remove ()
"Remove the highlight of the spelling error at point."
(when flyspell-correct-overlay
(delete-overlay flyspell-correct-overlay)
(setq flyspell-correct-overlay nil)))
(defun flyspell-correct--overlay-loc ()
"Return `cons' with start and end of `flyspell' overlay at point.
Returns nil if no overlay is found."
(let ((ovs (overlays-at (point)))
ov)
(while (and (not ov) ovs)
(let ((current (pop ovs)))
(when (flyspell-overlay-p current)
(setq ov current))))
(when ov
(let ((ov-start (overlay-start ov))
(ov-end (overlay-end ov)))
(cons ov-start ov-end)))))
;;; Automatically correct
;; based on `flyspell-popup-auto-correct-mode'
(defcustom flyspell-correct-auto-delay 1.6
"Delay in seconds before `flyspell-correct-previous' is called.
Use floating point numbers to express fractions of seconds."
:group 'flyspell
:type 'number
:safe #'numberp)
(defvar flyspell-correct-auto-mode-interface nil
"Interface to use in `flyspell-correct-auto-mode'.
When set to nil `flyspell-correct-interface' is used.")
(defvar flyspell-correct--auto-timer nil
"Timer to automatically call `flyspell-correct-previous'.")
(make-variable-buffer-local 'flyspell-correct--auto-timer)
(defvar flyspell-correct--auto-active-p nil)
(make-variable-buffer-local 'flyspell-correct--auto-active-p)
(defun flyspell-correct-auto-cancel-timer ()
"Cancel auto correct timer."
(when flyspell-correct--auto-timer
(cancel-timer flyspell-correct--auto-timer)
(setq flyspell-correct--auto-timer nil)))
(defun flyspell-correct-auto-soon ()
"Call `flyspell-correct-previous' delayed."
(flyspell-correct-auto-cancel-timer)
(when (and flyspell-mode
(not (bound-and-true-p flyspell-correct--auto-active-p)))
(setq
flyspell-correct--auto-timer
(run-at-time
flyspell-correct-auto-delay
nil
(lambda ()
(flyspell-correct-auto-cancel-timer)
(when (and flyspell-mode
(not (bound-and-true-p flyspell-correct--auto-active-p)))
(setq flyspell-correct--auto-active-p t)
(with-local-quit
(let ((flyspell-correct-interface
(if (bound-and-true-p flyspell-correct-auto-mode-interface)
flyspell-correct-auto-mode-interface
flyspell-correct-interface)))
(call-interactively #'flyspell-correct-previous)))
(setq flyspell-correct--auto-active-p nil)))))))
;;;###autoload
(define-minor-mode flyspell-correct-auto-mode
"Minor mode for automatically correcting word at point.
Take my advice and don't use this functionality unless you find
`flyspell-correct-previous' function useless for your purposes.
Seriously, just try named function for completion. You can find
more info in comment[1].
[1]:
https://github.com/syl20bnr/spacemacs/issues/6209#issuecomment-274320376"
:group 'flyspell
:lighter "auto-correct"
(if flyspell-correct-auto-mode
(progn
(add-hook 'post-command-hook 'flyspell-correct-auto-soon nil 'local))
(remove-hook 'post-command-hook 'flyspell-correct-auto-soon 'local)))
(provide 'flyspell-correct)
;;; flyspell-correct.el ends here