all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: Augusto Stoffel <arstoffel@gmail.com>
To: 61814@debbugs.gnu.org
Subject: bug#61814: [RFC] Asynchronous, jit-lock-based Flyspell
Date: Sun, 26 Feb 2023 15:56:00 +0100	[thread overview]
Message-ID: <87wn44a327.fsf@gmail.com> (raw)

[-- Attachment #1: Type: text/plain, Size: 774 bytes --]

Tags: patch

Find attached an attempt to make Flyspell talk to the spell checking
process outside of the main command loop using jit-lock.

To activate this mode of operation one should set 'flyspell-synchronous'
to nil before turning Flyspell on.

Not many of the numerous Flyspell options are supported, but hopefully
this can be considered useful even without covering all of them.  In any
case, let me know what you consider to be the essentials.

Also, one obvious glitch is that one gets JIT™ corrections for the word
being currently typed.  Before going on an writing some ugly logic to
avoid that, and since one can influence an overlay appearance when the
mouse pointer hovers it, I was wondering if there's something analogous
for the cursor.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Async-Flyspell.patch --]
[-- Type: text/patch, Size: 11328 bytes --]

From aaf4869b415c53dfcbef7d06959ba846d11fd338 Mon Sep 17 00:00:00 2001
From: Augusto Stoffel <arstoffel@gmail.com>
Date: Sun, 25 Sep 2022 17:09:31 +0200
Subject: [PATCH] Async Flyspell

---
 lisp/textmodes/flyspell.el | 209 ++++++++++++++++++++++++++++++++++++-
 1 file changed, 208 insertions(+), 1 deletion(-)

diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index 84c207b8a48..9b7a404a30a 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -532,7 +532,18 @@ flyspell-mode
 	  (flyspell-mode-on (called-interactively-p 'interactive))
 	(error (message "Error enabling Flyspell mode:\n%s" (cdr err))
 	       (flyspell-mode -1)))
-    (flyspell-mode-off)))
+    (flyspell-mode-off))
+  (unless flyspell-synchronous
+    (if flyspell-mode
+        (jit-lock-register #'flyspell-async--schedule)
+      (jit-lock-unregister #'flyspell-async--schedule))
+    (remove-hook 'post-command-hook #'flyspell-post-command-hook t)
+    (remove-hook 'pre-command-hook #'flyspell-pre-command-hook t)
+    (remove-hook 'after-change-functions #'flyspell-after-change-function t)
+    (save-restriction
+      (widen)
+      (flyspell-delete-all-overlays)
+      (remove-text-properties (point-min) (point-max) '(flyspell-pending t)))))
 
 ;;;###autoload
 (defun turn-on-flyspell ()
@@ -1997,6 +2008,25 @@ flyspell-auto-correct-word
           (setq flyspell-auto-correct-region nil))
       ;; Use the correct dictionary.
       (flyspell-accept-buffer-local-defs)
+      ;; Flyspell async case: populate suggestion list so we skip the
+      ;; else branch of the following `if' altogether.
+      (when-let* ((data (and (not flyspell-synchronous)
+                             (not flyspell-auto-correct-region)
+                             (get-char-property-and-overlay
+                              (point) 'flyspell-corrections)))
+                  (ov (cdr data))
+                  (corrections (car data))
+                  (word (buffer-substring-no-properties
+                                          (overlay-start ov)
+                                          (overlay-end ov)))
+                  (ring (setcdr (last corrections)
+                                (cons word corrections))))
+        (setq flyspell-auto-correct-pos (point)
+              flyspell-auto-correct-word word
+              flyspell-auto-correct-ring ring
+              flyspell-auto-correct-region (cons (overlay-start ov)
+                                                 (- (overlay-end ov)
+                                                    (overlay-start ov)))))
       (if (and (eq flyspell-auto-correct-pos pos)
                (consp flyspell-auto-correct-region))
           ;; We have already been using the function at the same location.
@@ -2381,6 +2411,183 @@ flyspell-already-abbrevp
 (defun flyspell-change-abbrev (table old new)
   (set (abbrev-symbol old table) new))
 
+;;; Asynchronous operation
+
+(defvar flyspell-synchronous t
+  "If non-nil, disable asynchronous Flyspell operation.")
+
+(defvar-local flyspell-async--current-request nil)
+(defvar-local flyspell-async--request-pool nil)
+(defvar-local flyspell-async--recheck-timer nil)
+(defvar flyspell-async--procs nil
+  "A collection of ispell processes for asynchronous Flyspell.")
+
+(defun flyspell-async-ignore-word-p (_start end)
+  (when flyspell-generic-check-word-predicate
+    (save-excursion
+      (goto-char end)
+      (not (funcall flyspell-generic-check-word-predicate)))))
+
+(defun flyspell-async--process-parameters ()
+  "Return a list of parameters for this buffer's ispell process.
+Buffers where this produces `equal' results can share their
+ispell process."
+  (list ispell-program-name
+        ispell-current-dictionary
+        ispell-current-personal-dictionary
+        ispell-extra-args))
+
+(defun flyspell-async--get-process ()
+  "Get an ispell process for the current buffer."
+  (let* ((params (flyspell-async--process-parameters))
+         (proc (plist-get flyspell-async--procs params #'equal)))
+    (if (process-live-p proc)
+        proc
+      (unless ispell-async-processp
+        (error "Asynchornous Flyspell requires `ispell-async-processp'"))
+      (setq proc (ispell-start-process))
+      (setq flyspell-async--procs
+            (plist-put flyspell-async--procs params proc #'equal))
+      (set-process-filter proc #'flyspell-async--process-filter)
+      (set-process-buffer proc (generate-new-buffer " *flyspell-async*"))
+      (process-send-string proc "!\n")  ;Enter terse mode
+      proc)))
+
+(defun flyspell-async--process-filter (proc string)
+  (with-current-buffer (process-buffer proc)
+    (save-excursion
+      (goto-char (point-max))
+      (insert string))
+    (when (re-search-forward "^\n" nil t)
+      (pcase-let ((`(,buffer ,tick ,start ,end)
+                   (process-get proc 'flyspell-async--current-request)))
+        (process-put proc 'flyspell-async--current-request nil)
+        (cond ((not (buffer-live-p buffer)))
+              ((not (eq tick (buffer-chars-modified-tick buffer)))
+               ;; Got a belated response, so schedule a retry
+               (flyspell-async--schedule-recheck buffer))
+              (t ;; Response is good, apply misspelling overlays
+               (let (misspellings)
+                 (goto-char (point-min))
+                 (while (re-search-forward
+                         (rx bol
+                             (or (seq (any "&?")
+                                      " " (group-n 1 (+ (not " ")))
+                                      " " (+ digit)
+                                      " " (group-n 2 (+ digit))
+                                      ":")
+                                 (seq "#"
+                                      " " (group-n 1 (+ (not " ")))
+                                      " " (group-n 2 (+ digit)))))
+                         nil t)
+                   (let ((word (match-string 1))
+                         (start (string-to-number (match-string 2)))
+                         corrections)
+                     (goto-char (match-end 0))
+                     (while (re-search-forward (rx (+ (not (any ", \n"))))
+                                               (pos-eol) t)
+                       (push (match-string 0) corrections))
+                     (push (list word start (nreverse corrections))
+                           misspellings)))
+                 (flyspell-async--put-overlays buffer start end misspellings))))
+        (delete-region (point-min) (point-max))
+        ;; Send next request to ispell process, if applicable
+        (let (request)
+          (while (and (setq request (pop (process-get proc 'flyspell-async--requests)))
+                      (pcase-let ((`(,buffer ,tick) request))
+                        (not (and (buffer-live-p buffer)
+                                  (eq tick (buffer-chars-modified-tick buffer))))))
+            (when (buffer-live-p buffer)
+              (flyspell-async--schedule-recheck (car request))))
+          (when request
+            (flyspell-async--send-request proc request)))))))
+
+(defun flyspell-async--put-overlays (buffer start end misspellings)
+  (with-current-buffer buffer
+    (with-silent-modifications
+      (put-text-property start end 'flyspell-pending nil)
+      (dolist (ov (overlays-in start end))
+        (when (eq 'flyspell-incorrect (overlay-get ov 'face))
+          (delete-overlay ov)))
+      (pcase-dolist (`(,word ,offset ,corrections) misspellings)
+        (when-let* ((wstart (+ start offset -1))
+                    (wend (+ wstart (length word)))
+                    (ov (unless (flyspell-async-ignore-word-p wstart wend)
+                          (make-flyspell-overlay wstart wend
+                                                 'flyspell-incorrect
+                                                 'highlight))))
+          ;; For debugging
+          (unless (equal word (buffer-substring-no-properties wstart wend))
+            (message "Shouldn't happen %s %s %s" word start (buffer-substring-no-properties wstart wend)))
+          (overlay-put ov 'flyspell-corrections corrections))))))
+
+(defun flyspell-async--send-request (proc request)
+  (process-put proc 'flyspell-async--current-request request)
+  (pcase-let ((`(,buffer _ ,start ,end) request))
+    (with-current-buffer buffer
+      (let ((text (buffer-substring-no-properties start end)))
+        ;; Redact control characters in `text'.
+        (dotimes (i (length text))
+          (when (< (aref text i) ?\s)
+            (aset text i ?\s)))
+        (process-send-string proc "^")
+        (process-send-string proc text)
+        (process-send-string proc "\n")))))
+
+(defun flyspell-async--schedule-recheck (buffer)
+  (message "Scheduled recheck") ;; For debugging
+  (with-current-buffer buffer
+    (when (timerp flyspell-async--recheck-timer)
+      (cancel-timer flyspell-async--recheck-timer))
+    (setq flyspell-async--recheck-timer
+          (run-with-idle-timer 0.1 nil #'flyspell-async--recheck buffer))))
+
+(defun flyspell-async--recheck (buffer)
+  (when (buffer-live-p buffer)
+    (with-current-buffer buffer
+      (let ((proc (flyspell-async--get-process))
+            (tick (buffer-chars-modified-tick))
+            (end (point-min))
+            (limit (point-max))
+            start)
+        (while (setq start (text-property-any end limit 'flyspell-pending t))
+          (setq end (or (text-property-not-all start limit 'flyspell-pending t)
+                        limit))
+          (push (list buffer tick start end) (process-get proc 'flyspell-async--requests)))
+        (when-let ((request (and (not (process-get proc 'flyspell-async--current-request))
+                                 (pop (process-get proc 'flyspell-async--requests)))))
+          (flyspell-async--send-request proc request))))))
+
+(defun flyspell-async--schedule (start end)
+  "Schedule a Flyspell check of region between START and END.
+This is intended be a member of `jit-lock-functions'."
+  (save-excursion ;; Extend region to include whole words
+    (goto-char start)
+    (setq start (if (re-search-backward "\\s-" nil t) (match-end 0) (point-min)))
+    (goto-char end)
+    (setq end (or (re-search-forward "\\s-" nil t) (point-max))))
+  (put-text-property start end 'flyspell-pending t)
+  (let ((proc (flyspell-async--get-process))
+        (request (list (current-buffer) (buffer-chars-modified-tick) start end)))
+    (if (process-get proc 'flyspell-async--current-request)
+        (push request (process-get proc 'flyspell-async--requests))
+      (flyspell-async--send-request proc request)))
+  `(jit-lock-bounds ,start . ,end))
+
+(define-minor-mode flyspell-async
+  "Asynchronous Flyspell"
+  :global nil :lighter " FlyAsync"
+  (flyspell-mode -1)
+  (if flyspell-async
+      (jit-lock-register #'flyspell-async--schedule)
+    (jit-lock-unregister #'flyspell-async--schedule))
+  (save-restriction
+    (widen)
+    (dolist (ov (overlays-in (point-min) (point-max)))
+        (when (eq 'flyspell-incorrect (overlay-get ov 'face))
+          (delete-overlay ov)))
+    (remove-text-properties (point-min) (point-max) '(flyspell-pending t))))
+
 (provide 'flyspell)
 
 ;;; flyspell.el ends here
-- 
2.39.2


             reply	other threads:[~2023-02-26 14:56 UTC|newest]

Thread overview: 14+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2023-02-26 14:56 Augusto Stoffel [this message]
2023-02-26 15:11 ` bug#61814: [RFC] Asynchronous, jit-lock-based Flyspell Eli Zaretskii
2023-02-26 15:36   ` Augusto Stoffel
2023-02-26 15:45     ` Eli Zaretskii
2023-02-27  8:31 ` Yuan Fu
2023-02-27  9:58   ` Augusto Stoffel
2023-03-04 11:41   ` Augusto Stoffel
2023-03-04 22:59     ` Yuan Fu
2023-03-06 10:52       ` Augusto Stoffel
2023-03-06 12:15         ` Eli Zaretskii
2023-03-08  0:45         ` Yuan Fu
2023-03-07 18:25       ` Juri Linkov
2023-03-08  8:50         ` Augusto Stoffel
2023-03-08 13:57           ` Eli Zaretskii

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=87wn44a327.fsf@gmail.com \
    --to=arstoffel@gmail.com \
    --cc=61814@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.