unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#61814: [RFC] Asynchronous, jit-lock-based Flyspell
@ 2023-02-26 14:56 Augusto Stoffel
  2023-02-26 15:11 ` Eli Zaretskii
  2023-02-27  8:31 ` Yuan Fu
  0 siblings, 2 replies; 14+ messages in thread
From: Augusto Stoffel @ 2023-02-26 14:56 UTC (permalink / raw)
  To: 61814

[-- 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


^ permalink raw reply related	[flat|nested] 14+ messages in thread
end of thread, other threads:[~2023-03-08 13:57 UTC | newest]

Thread overview: 14+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2023-02-26 14:56 bug#61814: [RFC] Asynchronous, jit-lock-based Flyspell Augusto Stoffel
2023-02-26 15:11 ` 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

Code repositories for project(s) associated with this public inbox

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

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).