;;; speck.el --- minor mode for spell checking ;; Copyright (C) 2006-2022 Martin Rudalics ;; Time-stamp: "2022-02-14 18:46:46 martin" ;; Author: Martin Rudalics ;; Keywords: spell checking ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; Speck is a minor mode for "specking" - spell-checking text displayed ;; in Emacs windows. Invoke the command `speck-mode' to toggle specking ;; of all windows showing the current buffer with your machine's default ;; dictionary. Invoke `speck-buffer' to speck all windows showing the ;; current buffer choosing the dictionaries of your like. ;; In its current version Speck works exclusively with buffers coded in ;; utf-8 and Hunspell. ;; _____________________________________________________________________________ ;; _ ;;; Variables _ ;; _____________________________________________________________________________ ;; _ (defvar speck-mode nil) (defvar speck-buffer-list nil "List of buffers managed by Speck.") (defvar speck-window-list nil "List of windows managed by Speck.") (defvar speck-delay-timer nil "Idle timer to start specking after `speck-delay' seconds.") (defvar speck-pause-timer nil "Idle timer to suspend specking for `speck-pause' seconds.") (defvar speck-marker (make-marker) "Marker used during querying.") (defvar speck-marker-window nil "Window where `speck-marker' was set.") (defvar speck-process nil "This buffer's Speck process.") (make-variable-buffer-local 'speck-process) (put 'speck-process 'permanent-local t) (defvar speck-process-marker nil "This buffer's Speck process marker.") (make-variable-buffer-local 'speck-process-marker) (put 'speck-process-marker 'permanent-local t) (defvar speck-buffer-dictionaries nil "This buffer's Speck dictionaries.") (make-variable-buffer-local 'speck-buffer-dictionaries) (put 'speck-buffer-dictionaries 'permanent-local t) (defvar speck-buffer-dictionaries-string "" "String specifying this buffer's Speck dictionaries.") (make-variable-buffer-local 'speck-buffer-dictionaries-string) (put 'speck-buffer-dictionaries-string 'permanent-local t) (defvar speck-buffer-options nil "This buffer's list of Speck options. This is the list of options passed to the spell engine.") (make-variable-buffer-local 'speck-buffer-options) (put 'speck-buffer-options 'permanent-local t) (defvar speck-ignore-list nil "List of words ignored in this buffer.") (make-variable-buffer-local 'speck-ignore-list) (put 'speck-ignore-list 'permanent-local t) (defvar speck-log nil "Non-nil when Speck logging is turned on") (defvar speck-log-buffer nil) (defun speck-log-buffer () "Return buffer for Speck logs." (if (buffer-live-p speck-log-buffer) speck-log-buffer (get-buffer-create "*speck-log*"))) ;; _____________________________________________________________________________ ;; _ ;;; Customization _ ;; _____________________________________________________________________________ ;; _ (defgroup speck nil "Another interface to Hunspell." :version "28.1" :group 'applications) (defcustom speck-delay 0.5 "Time in seconds to wait before specking. Start specking after Emacs has been idle for that many seconds." :type 'number :group 'speck) (defcustom speck-pause 0.1 "Time in seconds to pause specking. Give other timers a chance to run while specking." :type 'number :group 'speck) (defcustom speck-chunk-max 4096 "Maximum size of chunks send to spelling engine, in bytes. This specifies the maximum number of bytes Speck may send to the spelling engine in one step. It should not exceed the default buffer size of the underlying operating system for sending data over a pipe connection." :type 'number :group 'speck) (defcustom speck-replace-query nil "When non-nil query for further occurrences after correcting a word. The commands to correct a word are `speck-popup-menu-previous', `speck-popup-menu-next', `speck-replace-previous' and `speck-replace-next'." :type 'boolean :group 'speck) (defcustom speck-replace-preserve-point 'within "Where to move cursor within replaced text. Options are: before ... before replaced text within ... at same offset from begin of or after replaced text after .... after replaced text" :type '(choice (const :tag "Before" before) (const :tag "Within" within) (const :tag "After" after)) :group 'speck) ;; (defcustom speck-syntactic nil ;; "Non-nil means highlight misspelled words in comments or strings only. ;; Options are to highlight text anywhere in the buffer, text in ;; comments only, text in strings only, or text in comments or ;; strings. ;; The preferred way to set this option is by adding ;; (set (make-local-variable 'speck-syntactic) t) ;; to a major mode's hook." ;; :type '(choice (const :tag "Any" nil) ;; (const :tag "Comments" 'comments) ;; (const :tag "Strings" 'strings) ;; (const :tag "Comments or Strings" t)) ;; :group 'speck) (defcustom speck-hunspell-program (locate-file "hunspell" exec-path exec-suffixes 'file-executable-p) "File name of Hunspell program." :type '(choice (const :tag "Invalid" nil) (file :tag "File")) :group 'speck) (defun speck-hunspell-executable-p () "Return non-nil when `speck-hunspell-program' appears executable." (and (stringp speck-hunspell-program) (file-executable-p speck-hunspell-program))) (defcustom speck-hunspell-library-directory "/usr/share/hunspell/" "Name of Hunspell library directory. This should specify the absolute name of the directory where the Hunspell dictionaries reside." :type '(choice (const :tag "Invalid" nil) (file :tag "File")) :group 'speck) ;; The following is more useful than running Hunspell with the "-D" ;; option which may also return all sorts of myspell dictionaries. (defun speck-hunspell-dictionaries () "Return list of Hunspell dictionaries installed on this machine. This returns the relative file names sans extension of all files with extension \".dic\" in 'speck-hunspell-library-directory'." (when (and speck-hunspell-library-directory (file-exists-p speck-hunspell-library-directory)) (let ((files (directory-files speck-hunspell-library-directory nil "\\.dic$")) dictionaries) (dolist (file files) (setq dictionaries (cons (file-name-sans-extension file) dictionaries))) (sort dictionaries 'string-lessp)))) (defvar speck-hunspell-dictionaries (speck-hunspell-dictionaries) "List of Hunspell dictionaries installed on this machine. If you change them, you have to reload speck.el to make speck aware of the change.") (defun speck-hunspell-base-dictionaries () "Return list of Hunspell base dictionaries installed on this machine. This returns the relative file names sans extension of all files with extension \".aff\" in 'speck-hunspell-library-directory'." (when (and speck-hunspell-library-directory (file-exists-p speck-hunspell-library-directory)) (let ((files (directory-files speck-hunspell-library-directory nil "\\.aff$")) dictionaries) (dolist (file files) (setq dictionaries (cons (file-name-sans-extension file) dictionaries))) (sort dictionaries 'string-lessp)))) (defvar speck-hunspell-base-dictionaries (speck-hunspell-base-dictionaries) "List of Hunspell base dictionaries installed on this machine. A Hunspell base dictionary is one for which an affix (.aff) file exists in `speck-hunspell-library-directory'. If you change them, you have to reload speck.el to make speck aware of the change.") ;; Maybe we should check right here for UTF-8 awareness too ... (defun speck-hunspell-default-dictionary () (let ((lang (getenv "LANG")) dictionary) (when (string-match "^\\(.*\\)\\." lang) (setq dictionary (match-string-no-properties 1 lang)) (car (member dictionary speck-hunspell-base-dictionaries))))) (defvar speck-hunspell-default-dictionary (speck-hunspell-default-dictionary) "Default dictionary used by Hunspell on this machine.") (defvar speck-dictionaries speck-hunspell-dictionaries "List of dictionaries installed on this machine.") (defvar speck-base-dictionaries speck-hunspell-base-dictionaries "List of base dictionaries installed on this machine.") (defvar speck-dictionaries-history nil "History of dictionaries entered for `speck-buffer'.") ;; The radio button solution is not overly attractive but a simple way ;; to show all installed dictionaries to the customizer. (defcustom speck-default-dictionary speck-hunspell-default-dictionary "Speck's default dictionary. The default dictionary is used for specking a buffer unless you specify other dictionaries via `speck-dictionaries-alist' or `speck-buffer'." :type `(radio :indent 2 ,@(mapcar (lambda (entry) (list 'const :format "%v \n" entry)) speck-dictionaries)) :group 'speck) (defcustom speck-dictionaries-alist `((0 ,speck-default-dictionary)) "List associating integers with one or more dictionaries. This is the basic facility to specifying which dictionary to use when specking a buffer. Speck consults the associations specified here when determining which dictionaries to use for specking a buffer. The members of this list are lists of three elements. The first element should be a non-negative integer which can be used as numeric prefix argument for `speck-buffer' telling the latter to use the dictionaries specified by the remainder of the element for specking the current buffer. The second element specifies the \"base\" dictionary for specking a buffer when this association is used. It must be a member of `speck-base-dictionaries'. The third element specifies additional dictionaries that are consulted when this association is used. They must be members of `speck-dictionaries'. If no additional dictionaries are specified here, only the base dictionary is used for specking. Do not remove the association for 0 (zero). It is the default association and when it is missing, invoking `speck-mode' (or `speck-buffer' without a prefix argument) will break. You can, however, change the dictionaries specified by this association. Do not set up an association for negative values here since these are not handled correctly." :type `(repeat (list :format "%v\n" (integer :format "%v") (choice ,@(mapcar (lambda (entry) (list 'const :format "%v \n" entry)) speck-base-dictionaries)) (repeat (choice ,@(mapcar (lambda (entry) (list 'const :format "%v \n" entry)) speck-dictionaries))) (choice (const :tag "None" nil) (string :tag "String")))) :group 'speck) (defvar speck-wordchars-regexp nil "The wordchars of a speck process buffer.") (make-variable-buffer-local 'speck-wordchars-regexp) (put 'speck-wordchars-regexp 'permanent-local t) (defvar speck-wordchars-function nil "If non-nil, function used instead of `speck-wordchars-function'.") (make-variable-buffer-local 'speck-wordchars-function) (put 'speck-wordchars-function 'permanent-local t) (defcustom speck-wordchars-alist nil "Alist associating dictionary strings with word characters. Each entry of this alist contains a list of three elements: - a dictionary string - a string of characters - a function or nil. A dictionary string is obtained by concatenating all dictionaries specified for a buffer using a comma without spaces as separator. If `speck-lighter' is used, Speck by default displays a buffer's dictionary string in the buffer's mode line. See the example below for some valid dictionary strings. When setting up a chunk to send to the spell engine, Speck scans that chunk provided the dictionary string specified by the first element of this alist equals the dictionary string of the chunk's buffer. That scan replaces within that chunk any occurrences of a character specified by the second element of this alist not enclosed by two characters of word syntax. The default function to do that is `speck-wordchars' which gets called if the third element of this alist is nil and substitutes a space character for any such occurrence found. If the third element is a function, that function is called with no arguments and point immediately after the occurrence of such a character. It is up to that function to replace that character with exactly one other character (which must not be the newline character) or leave that character alone. Other buffer modifications may inevitably break specking. Note that any such substitutions are only done on a shadow copy of the buffer text; the original buffer is not affected by this operation. Removing such characters is necessary if the WORDCHARS entry of a Hunspell dictionary specifies a character that is also used in a buffer at the beginning or end of a word. For example, when you see problems when using the apostrophe \"'\" with the \"en_US\" dictionary you may want to try the following cure: - Make sure that \"'\" is specified by the WORDCHARS entry of en_US.aff. Otherwise, Hunspell may pitiless mark \"does\" in \"doesn't\" as misspelled. - Make sure that an entry for en_US and \"'\" is included in this alist. Otherwise, Hunspell will mark \"'does'\" as misspelled. An example for customizing this option in your init file is (customize-set-variable \\='speck-wordchars-alist \\='((\"en_US\" \"\\='\\=´\\=`\" nil) (\"fr_FR\" \"\\=’\\='\" nil) (\"en_US,fr_FR\" \"\\='\\=´\\=`\\=’\\='\" nil))) which includes the apostrophes typically used in the specified languages." :type '(repeat (list (string :tag "Dictionary String") (string :tag "Characters") (choice (const :tag "Use Speck's internal wordchars function" nil) (function :tag "User-defined function")))) :group 'speck) (defcustom speck-lighter t "When non-nil display a string in the mode-line when specking. Compare `speck-mode-line-specking' and `speck-mode-line-specked'." :type 'boolean :group 'speck) (defcustom speck-mode-line-specking t "String displayed in mode-line while specking window. Should contain a leading space. Selecting \"dictionary\" \(t) here means to display this buffer's dictionaries." :type '(choice (const :tag "Dictionary" t) string) :group 'speck) (defcustom speck-mode-line-specked t "String displayed in mode-line after window has been specked. Should contain a leading space. Selecting \"dictionary\" (t) here means to display this buffer's dictionaries." :type '(choice (const :tag "Dictionary" t) string) :group 'speck) (defface speck-guess '((((class color)) :underline (:style wave :color "red")) (t :underline t)) "Face for highlighting misspelled words with guesses." :group 'speck) (defface speck-miss '((((class color)) :underline (:style wave :color "orange")) (t :underline t)) "Face for highlighting misspelled words without guesses." :group 'speck) ;; (defface speck-mouse ;; '((((class color)) :background "thistle") ;; (t :underline t)) ;; "Face for highlighting misspelled word when the mouse is over it." ;; :group 'speck) (defface speck-query '((((class color)) :background "yellow") (t :underline t)) "Face for highlighting word in queries." :group 'speck-faces) (defface speck-mode-line-specking '((((class color)) :foreground "orange") (t nil)) "Face for Speck lighter when window is not fully specked." :group 'speck) (defface speck-mode-line-specked '((((class color)) :foreground "green") (t nil)) "Face for Speck lighter when window is fully specked." :group 'speck) (defface speck-specked '((((class color)) :background "lavenderblush1") (t :underline t)) "Face for highlighting specked text." :group 'speck) (defvar speck-face-inhibit-list nil "List of faces that inhibit specking. If this list is not empty, a word is not marked as misspelled if the face text property of its first character contains an element of this list. The recommended way to set this variable is via a major mode hook. The following code asserts that in `emacs-lisp-mode' text displayed with `font-lock-variable-name-face' or `font-lock-constant-face' is not marked as misspelled. (add-hook \\='emacs-lisp-mode-hook \\='(lambda () (set (make-local-variable \\='speck-face-inhibit-list) \\='(font-lock-variable-name-face font-lock-constant-face)))) This option overrides `speck-face-enforce-list' for text that has faces in both lists.") (defvar speck-face-enforce-list nil "List of faces that enforce specking. If this list is not empty, a word is not specked if the face text property of its first character does not contain an element of this list. The recommended way to set this variable is via a major mode hook. The following code asserts that in `emacs-lisp-mode' text displayed with `font-lock-comment-face' or `font-lock-doc-face' can be checked, while other program text remains unchecked. (add-hook \\='emacs-lisp-mode-hook \\='(lambda () (set (make-local-variable \\='speck-face-enforce-list) \\='(font-lock-comment-face font-lock-doc-face)) This option is overridden by `speck-face-inhibit-list' for text that has faces in both lists. Note that once text has been specked it will not be re-specked unless it is modified. Face changes done by font locking as a consequence of buffer changes, however, are usually done silently - they do not count as buffer modifications and are not detected by Speck. If you want to make sure that such changes are handled by Speck, set `speck-face-enforce-contextual' to non-nil.") (defvar speck-face-enforce-contextual nil "Non-nil means re-speck rest of buffer after a buffer modification. If this is nil, Speck re-scans only buffer text that actually changed after a buffer modification. This might be insufficient when `speck-face-enforce-list' is non-nil and Speck is supposed to react to face changes in the remainder of a buffer after such a modification. If you want to make sure that any such face changes are picked up by Speck, make this non-nil. In general, it is not recommended to do that because it may slow down both, specking and contextual re-fontification. In buffers where `speck-face-enforce-list' is nil, this option has no effect.") ;; _____________________________________________________________________________ ;; _ ;;; Utility Functions _ ;; _____________________________________________________________________________ ;; _ (defun speck-string (&optional begin end) "`buffer-substring-no-properties' with optional arguments." (buffer-substring-no-properties (or begin (point-min)) (or end (point-max)))) (defun speck-remove-overlays (&optional from to) "Remove all speck overlays between FROM and TO." (unless from (setq from (point-min))) (unless to (setq to (setq to (point-max)))) (when (< to from) (setq from (prog1 to (setq to from)))) (dolist (overlay (overlays-in from to)) (when (overlay-get overlay 'speck) (delete-overlay overlay)))) (defun speck-remove-text-properties (&optional from to which) "Remove all speck text properties between FROM and TO. WHICH, if non-nil, specifies the text properties to remove." (save-restriction (widen) (unless from (setq from (point-min))) (unless to (setq to (setq to (point-max)))) (when (< to from) (setq from (prog1 to (setq to from)))) (with-silent-modifications (remove-text-properties from to (or which '(speck nil specked nil)))))) (defun speck-add-window (&optional window) "Add WINDOW to `speck-window-list'." (setq window (or window (selected-window))) (unless (memq window speck-window-list) (with-current-buffer (window-buffer window) (when speck-mode (setq speck-window-list (cons window speck-window-list)) (speck-run-delay-timer) (speck-run-pause-timer) (force-mode-line-update))))) (defun speck-add-buffer-windows (&optional buffer) "Add BUFFER's windows to `speck-window-list'." (dolist (window (get-buffer-window-list buffer nil t)) (speck-add-window window))) (defun speck-remove-window (&optional window) "Remove WINDOW from `speck-window-list'." (setq window (or window (selected-window))) (setq speck-window-list (delq window speck-window-list)) (unless speck-window-list (when speck-delay-timer (cancel-timer speck-delay-timer) (setq speck-delay-timer nil)) (when speck-pause-timer (cancel-timer speck-pause-timer) (setq speck-pause-timer nil))) (force-mode-line-update)) (defun speck-remove-buffer-windows (&optional buffer) "Remove BUFFER's windows from `speck-window-list'." (dolist (window (get-buffer-window-list buffer nil t)) (speck-remove-window window))) (defun speck-add-buffer (&optional buffer) "Add BUFFER to `speck-buffer-list'." (setq buffer (or buffer (current-buffer))) (unless (memq buffer speck-buffer-list) (setq speck-buffer-list (cons buffer speck-buffer-list))) (dolist (window (get-buffer-window-list buffer nil t)) (speck-add-window window))) (defun speck-remove-buffer (&optional buffer) "Remove BUFFER from `speck-buffer-list'." (setq buffer (or buffer (current-buffer))) (speck-remove-buffer-windows buffer) (setq speck-buffer-list (remq buffer speck-buffer-list)) (with-current-buffer buffer (when (and speck-process (process-live-p speck-process)) (kill-buffer (process-buffer speck-process))) (setq speck-process nil))) (defun speck-goto-marker () "Go to `speck-marker' and make it point nowhere." (when (and (markerp speck-marker) (marker-position speck-marker) (window-live-p speck-marker-window)) (select-window speck-marker-window) (goto-char speck-marker) (set-marker speck-marker nil))) (defun speck-overlay-at-point (&optional at faces) "Return speck overlay at point. Optional argument AT non-nil means return overlay at position AT. Optional argument FACES non-nil means return overlay if and only if it has a face property in that list." (setq at (or at (point))) (let ((overlay (cdr (get-char-property-and-overlay at 'speck)))) (when (or (not faces) (and overlay (memq (overlay-get overlay 'face) faces))) overlay))) (defun speck-next-overlay (&optional arg faces) "Get first speck overlay ending after `point'. Optional argument ARG non-nil means return ARGth overlay after `point'. Optional argument FACES non-nil means return overlay if and only if it has a face property in that list." (save-excursion (setq arg (or arg 1)) (let ((overlay (speck-overlay-at-point nil faces))) (unless (and overlay (or (= arg 1) (progn (setq arg (1- arg)) (goto-char (overlay-end overlay)) (setq overlay nil)))) (save-restriction ;; This narrowing should be safe. (narrow-to-region (point) (window-end)) (while (and (not overlay) (< (point) (point-max)) (>= arg 0)) (goto-char (next-overlay-change (point))) (setq overlay (speck-overlay-at-point nil faces)) (when (and overlay (> arg 1)) (setq overlay nil) (setq arg (1- arg)))))) overlay))) (defun speck-previous-overlay (&optional arg faces) "Get first speck overlay starting before `point'. Optional argument ARG non-nil means return ARGth overlay before `point'. Optional argument FACES non-nil means return overlay if and only if it has a face property in that list." (save-excursion (setq arg (or arg 1)) (let ((overlay (speck-overlay-at-point nil faces))) (unless (and overlay (or (< (overlay-start overlay) (point)) (setq overlay nil)) (or (= arg 1) (progn (setq arg (1- arg)) (goto-char (overlay-start overlay)) (setq overlay nil)))) (save-restriction ;; This narrowing should be safe. (narrow-to-region (window-start) (point)) (while (and (not overlay) (> (point) (point-min)) (>= arg 0)) (goto-char (previous-overlay-change (point))) (setq overlay (speck-overlay-at-point nil faces)) (when (and overlay (> arg 1)) (setq overlay nil) (setq arg (1- arg)))))) overlay))) (defun speck-ignored (word) "Return non-nil if WORD is on the current buffer's list of ignored words." (member word speck-ignore-list)) (defun speck-ignore (word) "Add WORD to the current buffer's list of ignored words." (setq speck-ignore-list (cons word speck-ignore-list))) (defun speck-ignore-not (word) "Remove WORD from the current buffer's list of ignored words. Interactively prompt for the word to remove." (interactive "M") (setq speck-ignore-list (delete word speck-ignore-list)) ;; We have to re-speck the entire buffer and all its windows. (speck-remove-text-properties) (speck-add-buffer-windows)) ;; _____________________________________________________________________________ ;; _ ;;; Adding Words _ ;; _____________________________________________________________________________ ;; _ (defun speck-add-cleanup (overlay from to word) "Clean up current buffer after WORD has been added. OVERLAY is the overlay covering WORD, FROM and TO are its boundaries." (with-silent-modifications (delete-overlay overlay) (speck-remove-text-properties from to) ;; Remove all speck overlays and properties covering any instance ;; of WORD in this buffer. (save-excursion (save-restriction (widen) (goto-char (point-min)) (unless (get-char-property (point) 'speck) (goto-char (or (next-single-char-property-change (point) 'speck) (point-max))) (let (property) (while (not (eobp)) (setq from (point)) (setq to (or (next-single-char-property-change from 'speck) (point-max))) (setq overlay (cdr (get-char-property-and-overlay from 'speck))) (when (and overlay (string-equal (speck-string from to) word)) (delete-overlay overlay) (speck-remove-text-properties from to)) (goto-char (or (next-single-char-property-change (point) 'speck) (point-max))))))))) ;; Add buffer's windows to `speck-window-list'. (speck-add-buffer-windows)) (defun speck-add-word (overlay) "Add word covered by OVERLAY to dictionary or word list." (interactive) (let* ((from (overlay-start overlay)) (to (overlay-end overlay)) (word (speck-string from to)) (face (overlay-get overlay 'face)) (ignored (speck-ignored word))) (when overlay (overlay-put overlay 'face 'speck-query) (message (concat (format "\"p\" adds `%s' to personal dictionary" word) (unless (string-equal word (downcase word)) (format " (\"l\" adds `%s')" (downcase word))) ;; Suppress the following when an entry already exists. (unless ignored (format ", \"i\" ignores it")))) (unwind-protect (let* ((char (read-event)) (key (vector char)) (case-fold-search t)) (cond ((and (integerp char) (or (char-equal char ?p) (char-equal char ?*))) (process-send-string speck-process (concat "*" word "\n")) (process-send-string speck-process "#\n") (speck-add-cleanup overlay from to word)) ((and (integerp char) (or (char-equal char ?l) (char-equal char ?&))) (process-send-string speck-process (concat "&" word "\n")) (process-send-string speck-process "#\n") (speck-add-cleanup overlay from to word)) ((and (integerp char) (char-equal char ?i) (not ignored)) (speck-ignore word) (speck-add-cleanup overlay from to word)) (t (setq this-command 'mode-exited) (setq unread-command-events (append (listify-key-sequence key) unread-command-events))))) ;; Restore previous face. (when (overlayp overlay) (overlay-put overlay 'face face)))))) (defun speck-add-previous (&optional arg) "Add previous highlighted word on selected window. With ARG n do this for nth highlighted word preceding `point'." (interactive "p") (let ((overlay (speck-previous-overlay (or arg 1) '(speck-guess speck-miss)))) (if overlay (speck-add-word overlay) (let (message-log-max) (message "No word found ..."))))) (defun speck-add-next (&optional arg) "Add next highlighted word on selected window. With ARG n do this for nth highlighted word following `point'." (interactive "p") (let ((overlay (speck-next-overlay (or arg 1) '(speck-guess speck-miss)))) (if overlay (speck-add-word overlay) (let (message-log-max) (message "No word found ..."))))) ;; _____________________________________________________________________________ ;; _ ;;; Menus _ ;; _____________________________________________________________________________ ;; _ (defun speck-menu-tail (lower ignore) "Precalculated tail for popup menu." (append (list "" (cons "---" "---") ;; Reading the correct word from the minibuffer sounds ludicrous but ;; has the advantage that one does not have to move point for ;; correcting the word in place and some history may be available. (cons "Correct word via minibuffer" 'minibuffer) (cons "Add to personal dictionary" 'personal)) (when lower (list (cons "Add lower-case version" 'lower))) ;; IGNORE should be non-nil here, otherwise we should never have got ;; a menu here in the first place. (when ignore (list (cons "Ignore word in this session" 'ignore))))) (defun speck-popup-menu (posn &optional faces) "Pop up speck menu at position POSN." (let ((overlay (speck-overlay-at-point nil faces)) (process speck-process)) (when (and overlay process) ;; Preempt `speck-process' and unwind-protect the following to ;; assert that preemption is canceled (we do this to avoid that ;; specking continues during popups). (process-put process 'preempted t) (unwind-protect (let* ((from (overlay-start overlay)) (to (overlay-end overlay)) (word (speck-string from to)) (guesses (let (list) (nreverse (dolist (item (speck-word word) list) (setq list (cons (cons item item) list)))))) (ignored (speck-ignored word)) (speck-replace-query speck-replace-query) (replace (x-popup-menu posn ;; Put dictionary in menu (the user should ;; not have to guess which language is used). (list word (cons "" (or guesses (list ""))) (speck-menu-tail (not (string-equal word (downcase word))) (not ignored)))))) (while (eq replace 'query) (setq speck-replace-query (not speck-replace-query)) (setq replace (x-popup-menu posn (list word (cons "" (or guesses "" (list ""))) (speck-menu-tail (not (string-equal word (downcase word))) (not ignored)))))) (when (eq replace 'minibuffer) (setq replace (read-from-minibuffer "Correct word: " word minibuffer-local-map nil 'speck-replace-history word t))) (cond ((memq replace '(personal lower)) (if (eq replace 'personal) (process-send-string speck-process (concat "*" word "\n")) (process-send-string speck-process (concat "&" word "\n"))) (process-send-string speck-process "#\n") (speck-add-cleanup overlay from to word)) ((and (eq replace 'ignore) (not ignored)) (speck-ignore word) (speck-add-cleanup overlay from to word)) (replace (unless (atom replace) (setq replace (car replace))) (speck-replace-word from to word replace overlay)))) (process-put process 'preempted nil))))) (defun speck-popup-menu-at-point (&optional at point) "Pop up speck menu. Optional arguments AT and POINT if set mean popup menu at position AT and return to position POINT afterwards. At least one letter of the incorrect word must appear at the right of `point'." (interactive) (set-marker speck-marker (or point (point))) (setq speck-marker-window (selected-window)) (when at (goto-char at)) (let ((posn (posn-at-point))) ;; Always jump back to `speck-marker'. (unwind-protect (speck-popup-menu (list (list (car (posn-x-y posn)) (cdr (posn-x-y posn))) (posn-window posn))) (speck-goto-marker)))) (defun speck-popup-menu-previous (&optional arg) "Popup menu for previous word with guesses or miss. With ARG n do this for nth such word preceding `point'." (interactive "p") (let ((overlay (speck-previous-overlay (or arg 1) '(speck-guess speck-miss)))) (if overlay (speck-popup-menu-at-point (overlay-start overlay) (point)) (let (message-log-max) (message "No word found ..."))))) (defun speck-popup-menu-next (&optional arg) "Popup menu for next word with guesses or miss. With ARG n do this for nth such word following `point'." (interactive "p") (let ((overlay (speck-next-overlay (or arg 1) '(speck-guess speck-miss)))) (if overlay (speck-popup-menu-at-point (overlay-start overlay) (point)) (let (message-log-max) (message "No word found ..."))))) (defun speck-mouse-popup-menu (event) "Pop up speck menu at mouse-position. Should be bound to a click event." (interactive "e") (set-marker speck-marker (window-point) (current-buffer)) (setq speck-marker-window (selected-window)) (mouse-set-point event) ;; Always jump back to `speck-marker'. (unwind-protect (speck-popup-menu event) (speck-goto-marker))) ;; _____________________________________________________________________________ ;; _ ;;; Parsing _ ;; _____________________________________________________________________________ ;; _ (defun speck-make-overlay (from to face) "Make overlay from FROM to TO with face FACE." (unless (or (speck-ignored (speck-string from to)) (and (eq major-mode 'texinfo-mode) (or (eq (char-before from) ?\@) (save-excursion (goto-char from) (beginning-of-line) (looking-at "\\@\\(?:\\(?:def\\(?:un\\|var\\|opt\\|fn\\)\\)\\|end\\)"))))) (let ((overlay (make-overlay from to))) (overlay-put overlay 'speck t) (overlay-put overlay 'evaporate t) (overlay-put overlay 'face face) (overlay-put overlay 'keymap speck-overlay-map)))) (defun speck-wordchars (wordchars-regexp) "Speck's internal wordchars function." (goto-char (point-min)) ;; Replace char at BOB. (when (looking-at wordchars-regexp) (replace-match " ") (forward-char)) (while (re-search-forward wordchars-regexp nil t) (backward-char 1) (if (eq (char-syntax (char-before)) ?\w) (progn (forward-char) (when (or (eobp) (not (eq (char-syntax (char-after)) ?\w))) ;; Replace char at EOB or followed by a non-word-char. (delete-char -1) (insert ?\ ))) ;; Replace char preceded by a non-word-char. (delete-char 1) (insert ?\ ) (forward-char)))) (defun speck-log (&rest rest) "Log REST in our Log buffer." (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (when rest (insert (format "%s" (car rest))) (setq rest (cdr rest)) (while rest (insert (format " %s" (car rest))) (setq rest (cdr rest))) (insert "\n")))) (defun speck-chunk (from-1 to-1 process window-buffer from to) "Speck current buffer's chunk from FROM-1 to TO-1. The current buffer contains the stretch to parse when this gets called and FROM-1 and TO-1 are the start and end of the chunk to send to the spelling process PROCESS . WINDOW-BUFFER is the buffer where the chunk originally stems from and FROM and TO are the start and end positions of the stretch that contains this chunk. Any overlays representing guesses and misses are made in WINDOW-BUFFER by adding the chunk start position FROM-1 to the stretch start position FROM." (let (done pos at length word log-chunk log-output read) ;; Process stale output. (with-current-buffer (process-buffer process) (sit-for 0.05) (erase-buffer) (move-marker speck-process-marker (point-min))) (save-excursion ;; Insert a leading "^" and a final newline, send the region to ;; the spell process and revert the insertions immediately. (goto-char to-1) (insert-char ?\n) (goto-char from-1) (insert "^") (process-send-region process from-1 (+ to-1 2)) (goto-char from-1) (delete-char 1) (goto-char to-1) (delete-char 1)) (with-current-buffer (process-buffer process) (sit-for 0.1) (when speck-log (let ((size (- (point-max) (point-min))) (string (speck-string (point-min) (min (point-max) 20)))) (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert (format "FIRST: %s (%s-%s) %s\n" size from to string))))) ;; Quit if there is input. (while (and (not done) (or (and (not quit-flag ) (not (input-pending-p))) (progn (with-current-buffer window-buffer (when (process-live-p speck-process) (let ((process-buffer (process-buffer speck-process))) (when (buffer-live-p process-buffer) (kill-buffer process-buffer)))) (setq speck-process nil) (speck-re-start-process speck-buffer-dictionaries-string speck-buffer-options)) (when speck-log (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert "RESTART\n"))) (setq done nil))) (progn (sit-for 0.1) (when speck-log (let ((size (- (point-max) (point-min))) (string (speck-string 1 (min (point-max) 20)))) (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert (format "READ: %s (%s-%s) %s\n" size from to string))))) (or (> (point-max) (point-min)) (progn (when speck-log (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert "NO OUTPUT\n"))) (setq done nil))))) (when speck-log (setq log-output (speck-string))) (goto-char speck-process-marker) ;; This is still a hard loop we do not interrupt yet. But note ;; that it has all ingredients with the buffer position of each ;; misspelled item - so we could quit there, if we want to. (while (re-search-forward "\\(^& \\)\\|\\(^# \\)" nil 'noerror) (cond ((match-beginning 1) ; & (setq at (point)) (setq length (skip-chars-forward "^ ")) (setq word (speck-string at (point))) (skip-chars-forward " ") (skip-chars-forward "0-9") (skip-chars-forward " ") (setq at (point)) (skip-chars-forward "^:") (setq pos (string-to-number (speck-string at (point)))) (when (= (forward-line) 0) (move-marker speck-process-marker (point)) (with-current-buffer window-buffer (let ((from-2 (+ from pos -1)) (to-2 (+ from pos length -1))) (speck-make-overlay from-2 to-2 'speck-guess) (when speck-log (let ((string (speck-string from-2 to-2))) (cond ((not (string-equal word string)) (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert (format "BAD WORD: %s at: %s is not: %s\n" word from-2 string)))) ((and (< to-2 (point-max)) (eq (char-syntax (char-after to-2)) ?\w)) (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert (format "INCOMPLETE: %s at: %s is not: %s\n" word from-2 string))))))))))) ((match-beginning 2) ; # (setq at (point)) (setq length (skip-chars-forward "^ ")) (setq word (speck-string at (point))) (skip-chars-forward " ") (setq at (point)) (skip-chars-forward "0-9") (setq pos (string-to-number (speck-string at (point)))) (when (= (forward-line) 0) (move-marker speck-process-marker (point)) (with-current-buffer window-buffer (let ((from-2 (+ from pos -1)) (to-2 (+ from pos length -1))) (speck-make-overlay from-2 to-2 'speck-guess) (when speck-log (let ((string (speck-string from-2 to-2))) (cond ((not (string-equal word string)) (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert (format "BAD WORD: %s at: %s is not: %s\n" word from-2 string)))) ((and (< to-2 (point-max)) (eq (char-syntax (char-after to-2)) ?\w)) (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert (format "INCOMPLETE: %s at: %s is not: %s\n" word from-2 string))))))))))))) ;; With errors we get two newlines at EOB, without errors a ;; buffer containing one newline character only. Set done when ;; the spelling engine has sent us everything for this chunk. (when (and (eq (char-before (point-max)) ?\n) (or (= (point-min) (1- (point-max))) (eq (char-before (1- (point-max))) ?\n))) (setq done t))) (when speck-log (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert (format "CHUNK DONE: %s (%s-%s)\n" done from to)))) done))) (defun speck-stretch (from to) "Speck current buffer's stretch from FROM to TO." (let ((done t) (process speck-process) (window-buffer (current-buffer)) (wordchars-function speck-wordchars-function) (wordchars-regexp speck-wordchars-regexp) from-1 to-1 log-stretch) (with-current-buffer (get-buffer-create "*speck-stretch*") (setq buffer-undo-list t) (erase-buffer) ;; A real `insert-buffer-substring-no-properties' is a pipe dream. (insert-buffer-substring-no-properties window-buffer from to) ;; Replace wordchars with spaces. It would be tempting to check ;; these when making the overlays but then we would have to send ;; the word proper a second time because the word might be ;; misspelled or it might be enclosed by the wordchars, or both! ;; Sending the word a second time would mean to interrupt the ;; underlying chunk logic so we do that replacement here. (when wordchars-function (goto-char (point-min)) (funcall wordchars-function wordchars-regexp)) ;; Replace newlines with spaces. We probably should do that for ;; chunks only but it's too tempting to run it in one rush here. (goto-char (point-min)) (while (re-search-forward "\n" nil 'noerror) (replace-match " ")) (when speck-log ;; Log stretch - its first and last lines, at least. (goto-char (point-min)) (if (and (re-search-forward "\n" nil 'noerror) (not (eobp))) (let ((point (point))) (setq log-stretch (speck-string nil (1- (point)))) (goto-char (point-max)) (skip-chars-backward "[ \n\t]") (if (> (point) point) (setq log-stretch (concat log-stretch "..." (speck-string (line-beginning-position) (point)))) (setq log-stretch (speck-string nil (point))))) (setq log-stretch (speck-string))) (with-current-buffer (speck-log-buffer) (insert (format "STRETCH (%s-%s): %s\n" from to log-stretch)))) ;; Extract chunks from stretch. (goto-char (point-min)) (setq from-1 (point-min)) (while (and done (< from-1 (point-max))) ;; Set to-1 to the largest buffer position preceding a ;; 'speck-chunk-max' byte offset after from-1. (let ((to-1 (or (byte-to-position (+ (position-bytes from-1) speck-chunk-max)) (point-max)))) (when (< to-1 (point-max)) (goto-char to-1) (skip-chars-backward "^ \t") (setq to-1 (point))) (if (<= to-1 from-1) ;; If searching for a whitespace has got us before from-1, ;; we have a chunk that does not fit, that is, an overly ;; long non-whitespace string. Just mark it as specked. (progn (skip-chars-forward "^ \t") (setq to-1 (point)) (with-current-buffer window-buffer (let ((from-2 (+ from from-1 -1)) (to-2 (+ from to-1 -1))) (with-silent-modifications (put-text-property from-2 to-2 'specked t) (when speck-log (with-current-buffer (speck-log-buffer) (insert (format "IGNORE: %s-%s\n" from-2 to-2))) (put-text-property from-2 to-2 'face 'speck-specked))))) (setq to-1 (point))) ;; A chunk that fits, process it. (setq done (speck-chunk from-1 to-1 process window-buffer (+ from from-1 -1) (+ from to-1 -1))) (when done (let ((from-2 (+ from from-1 -1)) (to-2 (+ from to-1 -1))) (when speck-log (with-current-buffer (speck-log-buffer) (insert (format "SPECKED %s-%s\n" from-2 to-2)))) (with-current-buffer window-buffer (with-silent-modifications (put-text-property from-2 to-2 'specked t) (when speck-log (put-text-property from-2 to-2 'face 'speck-specked))))))) (setq from-1 to-1))) (when speck-log (with-current-buffer (speck-log-buffer) (goto-char (point-max)) (insert (format "STRETCH DONE: %s (%s-%s)\n" done from to)))) done))) ;; (setq speck-face-enforce-list '(font-lock-doc-face font-lock-comment-face)) (defun speck-enforce-face-at-point () "Return non-nil when a face property at point is enforced." (unless (eobp) (let ((faces (get-text-property (point) 'face))) (cond ((not faces) nil) ((listp faces) ;; We have a list of face properties. (catch 'found (dolist (face faces t) (when (memq face speck-face-enforce-list) (throw 'found t))))) (t ; Atom. (memq faces speck-face-enforce-list)))))) (defun speck-window (&optional window) "Speck specified WINDOW." (let* ((window (or window (selected-window))) (window-buffer (window-buffer window)) (window-start (window-start window)) (window-end (window-end window)) (from window-start) (done t) to from-1) (with-current-buffer window-buffer (when (and speck-process (not (process-get speck-process 'preempted))) (with-silent-modifications (let (minibuffer-auto-raise message-log-max) (save-excursion (when speck-face-enforce-list (save-excursion (goto-char window-start) ;; from-1 non-nil points at the first position that ;; should not be specked. (setq from-1 (unless (speck-enforce-face-at-point) (point))) (while (and (< (point) window-end) (goto-char (next-single-property-change (point) 'face nil window-end))) (cond ((or (= (point) window-end) (speck-enforce-face-at-point)) (when from-1 (with-silent-modifications ;; Mark text from from-1 to point as specked. (put-text-property from-1 (point) 'specked t) (when speck-log (put-text-property from-1 (point) 'face 'speck-specked)))) (setq from-1 nil)) (t ;; Expand from previous from-1 or start new ;; stretch that should not be specked. (setq from-1 (or from-1 (point)))))))) (while (and (or (and (not quit-flag) (not (input-pending-p))) (setq done nil)) (setq from (text-property-any from window-end 'specked nil))) (setq to (next-single-property-change from 'specked nil window-end)) (when speck-log (speck-log "WINDOW:" window "buffer:" window-buffer "start:" window-start "end:" window-end "from:" from "to:" to)) (unless (speck-stretch from to) (setq done nil)) (setq from to))))))) (when done (speck-remove-window window)))) (defun speck-respeck (delay) "Speck again after DELAY seconds." (timer-set-idle-time speck-pause-timer (current-idle-time)) (timer-inc-time speck-pause-timer (or delay 0)) (timer-activate-when-idle speck-pause-timer t)) (defun speck-windows (&optional pause) "Speck windows on `speck-window-list'. Works correctly if and only if the optional argument PAUSE is nil when triggered by `speck-delay-timer' and non-nil when triggered by `speck-pause-timer'." (unless pause ;; When `pause' is nil cancel `speck-pause-timer' (in pathological ;; cases this might interfere with the current call). (cancel-timer speck-pause-timer)) (cond ((or (input-pending-p) ;; (active-minibuffer-window) ; do we need this? executing-kbd-macro defining-kbd-macro) ;; Pause by `speck-delay' seconds (maybe the list above should be ;; extended). (speck-respeck speck-delay)) ;; Test selected window first. ((and (memq (selected-window) speck-window-list) (or (let ((buffer (window-buffer))) (and (local-variable-p 'speck-mode buffer) (buffer-local-value 'speck-mode buffer))) ;; The selected window is not suitable for specking, remove ;; it from `speck-window-list' (could it ever get there?). (and (speck-remove-window (selected-window)) nil))) (speck-window)) (t (let* (windows-to-remove (window (catch 'found ;; Scan `speck-window-list' (dolist (window speck-window-list) (if (and (window-live-p window) (let ((buffer (window-buffer window))) (and (local-variable-p 'speck-mode buffer) (buffer-local-value 'speck-mode buffer)))) ;; `window' is suitable for specking, return it. (throw 'found window) ;; `window' is not suitable for specking, remove it ;; from `speck-window-list'. FIXME, this is hairy ... (setq windows-to-remove (cons window windows-to-remove))))))) ;; Remove dead windows. (while windows-to-remove (speck-remove-window (car windows-to-remove)) (setq windows-to-remove (cdr windows-to-remove))) ;; Speck `window'. (speck-window window)))) (when speck-window-list ;; Pause by `speck-pause' seconds. (speck-respeck speck-pause))) (defun speck-after-change (start end old-len) "Speck after a text change. START, END, and OLD-LEN have the usual meanings." (when speck-mode (save-excursion (save-restriction (widen) (goto-char start) (skip-chars-backward "^ \n\t") (skip-chars-forward " \n\t") (setq start (point)) (goto-char end) (skip-chars-forward "^ \n\t") (skip-chars-backward " \n\t") (setq end (point)) (with-silent-modifications (if (and speck-face-enforce-list speck-face-enforce-contextual) (progn (speck-remove-overlays start (point-max)) (speck-remove-text-properties start (point-max))) (speck-remove-overlays start end) (speck-remove-text-properties start end))))) (speck-add-buffer-windows))) (defun speck-window-scroll (window _start) "Speck after WINDOW was scrolled." (speck-add-window window)) (defun speck-window-state-change (window) "Speck after WINDOW changed state." (speck-add-window window)) ;; _____________________________________________________________________________ ;; _ ;;; Keymaps _ ;; _____________________________________________________________________________ ;; _ (defvar speck-overlay-map (let ((map (make-sparse-keymap))) (define-key map [down-mouse-3] 'speck-mouse-popup-menu) map) "Speck mouse map.") (defun speck-make-mode-map (map) "Assign `speck-mode-keys' to MAP which should be `speck-mode-map'." (when (boundp 'speck-mode-keys) (define-key map (nth 0 speck-mode-keys) 'speck-popup-menu-previous) (define-key map (nth 1 speck-mode-keys) 'speck-popup-menu-next) (define-key map (nth 2 speck-mode-keys) 'speck-replace-previous) (define-key map (nth 3 speck-mode-keys) 'speck-replace-next) (define-key map (nth 4 speck-mode-keys) 'speck-add-previous) (define-key map (nth 5 speck-mode-keys) 'speck-add-next))) (defvar speck-mode-map (let ((map (make-sparse-keymap))) (speck-make-mode-map map) map) "Keymap used by `speck-mode'. `speck-make-mode-map' fills it.") (defcustom speck-mode-keys '([(control ?\.)] [(control meta ?\.)] [(control ?\,)] [(control meta ?\,)] [(control ?\+)] [(control meta ?\+)] [(control ?\!)] [(control meta ?\!)] [(control ?\?)] [(control meta ?\?)]) "Keys used by `speck-mode'." :type '(list (key-sequence :tag "Popup menu at previous word" :format "\n %t %v\n\n" :value '[(control ?\.)] :size 20) (key-sequence :tag "Popup menu at next word " :format " %t %v\n\n" :value '[(control meta ?\.)] :size 20) (key-sequence :tag "Replace previous word " :format " %t %v\n\n" :value '[(control ?\,)] :size 20) (key-sequence :tag "Replace next word " :format " %t %v\n\n" :value '[(control meta ?\,)] :size 20) (key-sequence :tag "Accept previous word " :format " %t %v\n\n" :value '[(control ?\+)] :size 20) (key-sequence :tag "Accept next word " :format " %t %v\n\n" :value '[(control meta ?\+)] :size 20) (key-sequence :tag "Spell-check region " :format " %t %v\n\n" :value '[(control ?\!)] :size 20) (key-sequence :tag "Change dictionary " :format " %t %v\n\n" :value '[(control meta ?\!)] :size 20) (key-sequence :tag "Set language " :format " %t %v\n\n" :value '[(control ?\?)] :size 20) (key-sequence :tag "Set option " :format " %t %v\n\n" :value '[(control meta ?\?)] :size 20)) :set #'(lambda (symbol value) (when (and (boundp 'speck-mode-map) ;; Paranoia. (boundp 'speck-mode-keys) (listp speck-mode-keys)) (dolist (key speck-mode-keys) (define-key speck-mode-map key nil))) (set-default symbol value) (when (boundp 'speck-mode-map) (speck-make-mode-map speck-mode-map))) :group 'speck) (defun speck-assign-keys-to-map (map keys) "Assign KEYS to MAP. MAP must be a keymap, KEYS a list of (command . key) pairs." (dolist (pair keys) (define-key map (cdr pair) (car pair)))) (defcustom speck-replace-keys '((help . [(control ?\?)]) (help . [(control ?\h)]) (help . [f1]) (help . [help]) (accept . [(control ?\!)]) (accept-and-quit . [(control ?\.)]) (reject-and-quit . [(control ?\-)]) (reject-and-quit . [(control ?\g)]) (reject-and-quit . [(control ?\])]) (reject-and-quit . [escape]) (forward . [(control ?\,)]) (backward . [(control meta ?\,)])) "Keys used by `speck-mode' during replacement." :type '(repeat (cons :format "%v" (choice :format " %[Command%] %v" (const :format "help " help) (const :format "accept " accept) (const :format "accept-and-quit" accept-and-quit) (const :format "reject-and-quit" reject-and-quit) (const :format "forward " forward) (const :format "backward " backward)) (key-sequence :format " Key: %v\n\n" :size 20))) :set #'(lambda (symbol value) ;; Don't "and" these. (when (boundp 'speck-replace-map) (when (boundp 'speck-replace-keys) (dolist (pair speck-replace-keys) ;; Reset them all. (define-key speck-replace-map (cdr pair) nil)))) (set-default symbol value) (when (boundp 'speck-replace-map) (speck-assign-keys-to-map speck-replace-map speck-replace-keys))) :group 'speck) (defvar speck-replace-map (let ((map (make-sparse-keymap))) (speck-assign-keys-to-map map speck-replace-keys) map) "Dummy keymap for `speck-replace'.") (defcustom speck-replace-query-keys '((help . [(control ?\?)]) (help . [(control ?\h)]) (help . [f1]) (help . [help]) (accept . [(control ?\!)]) (accept . [?\ ]) (accept . [return]) (accept-and-quit . [(control ?\.)]) (reject . [(control ?\-)]) (reject-and-quit . [(control ?\g)]) (reject-and-quit . [(control ?\])]) (reject-and-quit . [escape]) (forward . [(control ?\,)]) (forward . [tab]) (backward . [(control meta ?\,)]) (backward . [(shift tab)])) "Keys used by `speck-mode' during query replacement." :type '(repeat (cons :format "%v" (choice :format " %[Command%] %v" (const :format "help " help) (const :format "accept " accept) (const :format "accept-and-quit" accept-and-quit) (const :format "reject " reject) (const :format "reject-and-quit" reject-and-quit) (const :format "forward " forward) (const :format "backward " backward)) (key-sequence :format " Key: %v\n\n" :size 20))) :set #'(lambda (symbol value) ;; Don't "and" these. (when (boundp 'speck-replace-query-map) (when (boundp 'speck-replace-query-keys) (dolist (pair speck-replace-query-keys) ;; Reset them all. (define-key speck-replace-query-map (cdr pair) nil)))) (set-default symbol value) (when (boundp 'speck-replace-query-map) (speck-assign-keys-to-map speck-replace-query-map speck-replace-query-keys))) :group 'speck) (defvar speck-replace-query-map (let ((map (make-sparse-keymap))) (speck-assign-keys-to-map map speck-replace-query-keys) map) "Dummy keymap for `speck-replace-query'.") (defun speck-key-help (command keys suffix) "Return string of keys in KEYS executing COMMAND. KEYS must be either `speck-replace-keys' or `speck-replace-query-keys'." (let ((string "")) (dolist (key keys) (when (eq command (car key)) (setq string (concat string (unless (string-equal string "") ", ") ; Looks better. (key-description (cdr key)))))) (if (string-equal string "") "" (concat " " string suffix)))) ; Prefix this with two spaces. (defun speck-keys-help (keys &optional first) "Return a readable list of keybindings for help." (concat ;; Use a fixed list of commands here, it's simpler. Yes we do ;; allocate string space here, but after all this should be used only ;; sporadically. (speck-key-help 'accept keys (concat " to accept the replacement and " (if first "query further occurrences" "continue querying") "\n")) (speck-key-help 'accept-and-quit keys " to accept the replacement and quit querying\n") (speck-key-help 'reject keys " to reject the replacement and continue querying\n") (speck-key-help 'reject-and-quit keys " to reject the replacement and quit querying\n") (speck-key-help 'forward keys " to display the next replacement\n") (speck-key-help 'backward keys " to display the previous replacement\n") (speck-key-help 'help keys " to display this help\n"))) ;; _____________________________________________________________________________ ;; _ ;;; Replacing words _ ;; _____________________________________________________________________________ ;; _ (defun speck-replace-word (from to word replace &optional overlay) "Replace WORD within FROM and TO by REPLACE. Optional OVERLAY non-nil means remove that overlay. PROPERTY non-nil means put this property on REPLACE." (let (move-to) (when overlay (delete-overlay overlay)) (when (and (eq (marker-buffer speck-marker) (current-buffer)) (<= from speck-marker) (<= speck-marker to)) (cond ((eq speck-replace-preserve-point 'before) (setq move-to from)) ((and (eq speck-replace-preserve-point 'within) (<= from speck-marker) (<= speck-marker to) (< (- speck-marker from) (length replace))) (setq move-to (marker-position speck-marker))) (t (setq move-to (+ from (length replace)))))) (delete-region from to) (goto-char from) (insert replace) (when move-to (set-marker speck-marker move-to)) ;; The following never worked here. Maybe I misunderstand this ;; completely. ;; (speck-send-replacement word replace) )) (defun speck-replace-put-overlay (overlay from to offset replace) "Put OVERLAY and goto FROM or TO." (if offset (cond ((eq speck-replace-preserve-point 'before) (overlay-put overlay 'display replace) (goto-char from)) ((and (eq speck-replace-preserve-point 'within) (< offset (length replace))) (overlay-put overlay 'display (concat (substring replace 0 offset) (propertize (substring replace offset (1+ offset)) 'cursor t) (substring replace (1+ offset)))) (goto-char from)) (t (overlay-put overlay 'display replace) (goto-char to))) (overlay-put overlay 'display replace))) (defun speck-replace-query (word replace) "Query replace further occurrences of WORD by something like REPLACE." (let ((regexp (concat "\\<" (regexp-quote word) "\\>")) (query t) (case-fold-search t) (text (substitute-command-keys "Replace `%s' with `%s'? Type \\\\[help] for help."))) ;; Consider widening here. ;; Consider using `undo-boundary' here. (goto-char (point-min)) (while (and query (not (eobp)) (re-search-forward regexp nil t)) (let* ((from (match-beginning 0)) (to (match-end 0)) (word (speck-string from to)) (begin (line-beginning-position)) (end (line-beginning-position 2)) guesses tail) (when (and (not (and query-replace-skip-read-only ;; Ignore matches with read-only property. (text-property-not-all (match-beginning 0) (match-end 0) 'read-only nil))) (save-excursion (and (goto-char from) ;; When we enforce face, make sure to not ;; operate outside of such a face. (or (not speck-face-enforce-list) (speck-enforce-face-at-point)) ;; occur. (consp (setq guesses (speck-word word)))))) (when (setq tail (member-ignore-case replace guesses)) ;; REPLACE is in `guesses'. (unless (eq guesses tail) ;; Move REPLACE to head of list. (setq guesses (cons (car tail) (delete (car tail) guesses))))) (let* ((replace (car guesses)) (reps-vector (vconcat guesses)) (reps-index 0) (reps-max (1- (length reps-vector))) (overlay (or (speck-overlay-at-point from '(speck-guess speck-miss)) (make-overlay from to))) (def 'forward) change key) (overlay-put overlay 'speck t) (overlay-put overlay 'display replace) (overlay-put overlay 'face 'speck-query) (unwind-protect (while (memq def '(forward backward help)) (setq query nil) (setq def nil) (let ((message-log-max nil)) ;; This message is needed to avoid echoing typed ;; characters in the echo area (see replace.el). (message text word replace)) (setq key (vector (read-event))) (setq def (lookup-key speck-replace-query-map key)) (cond ((eq def 'accept) (setq change t) (setq query t)) ((eq def 'accept-and-quit) (setq change t)) ((eq def 'reject) (setq query t)) ((eq def 'reject-and-quit)) ((eq def 'forward) (setq reps-index (if (= reps-index reps-max) 0 (1+ reps-index))) (setq replace (aref reps-vector reps-index)) (overlay-put overlay 'display replace)) ((eq def 'backward) (setq reps-index (if (zerop reps-index) reps-max (1- reps-index))) (setq replace (aref reps-vector reps-index)) (overlay-put overlay 'display replace)) ((eq def 'help) (with-output-to-temp-buffer "*Help*" (princ (concat "Replace `" word "' with `" replace "'? Type\n\n" (speck-keys-help speck-replace-query-keys) "\nAnything else will accept the replacement and reread as command.\n")) (with-current-buffer standard-output (help-mode)))) (t ;; The mode-exited stuff is not clean but let's try ;; doing this as in `query-replace'. (setq this-command 'mode-exited) (setq unread-command-events (append (listify-key-sequence key) unread-command-events)) (setq change t)))) (cond (change (speck-replace-word from to word replace overlay)) ((overlayp overlay) ;; Install or restore overlay properties. (overlay-put overlay 'display nil) ; Silly (overlay-put overlay 'face 'speck-guess))) (unless query (speck-goto-marker))))))))) (defun speck-replace (overlay) "Replace word covered by OVERLAY with corrections." (let ((process speck-process)) (when (and overlay process) (process-put process 'preempted t) (unwind-protect (let* ((from (overlay-start overlay)) (to (overlay-end overlay)) (offset (when (and (< from (point)) (< (point) to)) ;; Offset of `point' wrt `from'. (- (point) from))) (word (speck-string from to)) (guesses (speck-word word)) (text ;; We can't use any "`" or "'" here, these characters ;; may be part of the word or the replacement. Hence ;; entirely rely on faces (`speck-query') to set them ;; apart from the rest. (substitute-command-keys (concat "Replace %s with %s ? Type \\\\[help] for help.")))) (if (null guesses) (message "No corrections found") (let* ((replace (car guesses)) (guess-vector (vconcat guesses)) (guess-index 0) (guess-max (1- (length guess-vector))) (def 'forward) change query key) (set-marker speck-marker (point)) (setq speck-marker-window (selected-window)) ; <---- (speck-replace-put-overlay overlay from to offset replace) (overlay-put overlay 'face 'speck-query) (unwind-protect (progn (while (memq def '(forward backward help)) (let ((message-log-max nil)) ;; This message is also needed to avoid ;; echoing typed characters in the echo area ;; (see replace.el). (message text (propertize word 'face 'speck-query) (propertize replace 'face 'speck-query))) (setq key (vector (read-event))) (setq def (lookup-key speck-replace-map key)) (cond ((eq def 'accept) (setq change t) (setq query t)) ((eq def 'accept-and-quit) (setq change t)) ((memq def '(reject reject-and-quit))) ((eq def 'forward) (setq guess-index (if (= guess-index guess-max) 0 (1+ guess-index))) (setq replace (aref guess-vector guess-index)) (speck-replace-put-overlay overlay from to offset replace)) ((eq def 'backward) (setq guess-index (if (zerop guess-index) guess-max (1- guess-index))) (setq replace (aref guess-vector guess-index)) (speck-replace-put-overlay overlay from to offset replace)) ((eq def 'help) (with-output-to-temp-buffer "*Help*" (princ (concat "Replace `" word "' with `" replace "'? Type\n\n" (speck-keys-help speck-replace-keys t) "\nAnything else will accept the replacement and reread as command.\n")) (with-current-buffer standard-output (help-mode)))) (t ;; The mode-exited stuff is not clean but ;; let's try doing this as in `query-replace'. (setq this-command 'mode-exited) (setq unread-command-events (append (listify-key-sequence key) unread-command-events)) (setq change t))))) (cond (change (speck-replace-word from to word replace overlay)) ((overlayp overlay) ;; Restore overlay properties. (overlay-put overlay 'display nil) ; Silly (overlay-put overlay 'face 'speck-guess))) (when (and query speck-replace-query) (speck-replace-query (downcase word) replace)) (speck-goto-marker))))) (process-put process 'preempted nil))))) (defun speck-replace-previous (&optional arg) "Correct previous word with guesses in place. With ARG n do this for nth such word preceding `point'." (interactive "p") (let ((overlay (speck-previous-overlay (or arg 1) '(speck-guess)))) (if overlay (speck-replace overlay) (let (message-log-max) (message "No previous word found ..."))))) (defun speck-replace-next (&optional arg) "Correct next word with guesses in place. With ARG n do this for nth such word following `point'." (interactive "p") (let ((overlay (speck-next-overlay (or arg 1) '(speck-guess)))) (if overlay (speck-replace overlay) (let (message-log-max) (message "No next word found ..."))))) ;; _____________________________________________________________________________ ;; _ ;;; Syntactic _ ;; _____________________________________________________________________________ ;; _ ;; (defalias 'speck-jitify 'jit-lock-fontify-now) ;; (defalias 'speck-lazify 'lazy-lock-fontify-region) ;; ;; Stefan's idea of doing this. ;; (defsubst speck-ensure-fontified (start end) ;; (cond ;; ((and (boundp 'jit-lock-mode) (symbol-value 'jit-lock-mode)) ;; (speck-jitify start end)) ;; ((and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode)) ;; (speck-lazify start end)))) ;; (defun speck-syntactic-p () ;; "Return t when character at `point' may be syntactically checked." ;; (and (or (not speck-syntactic) ;; (let ((parse-state (syntax-ppss))) ;; (or (and (nth 3 parse-state) ;; (memq speck-syntactic '(strings t))) ;; (and (nth 4 parse-state) ;; (memq speck-syntactic '(comments t)))))) ;; (or (not speck-face-inhibit-list) ;; (progn ;; (unless (get-text-property (point) 'fontified) ;; (speck-ensure-fontified ;; (line-beginning-position) (line-end-position)) ;; nil)) ;; (let ((faces (get-text-property (point) 'face))) ;; ;; Inhibit specking this word if (one of) its face(s) is in ;; ;; `speck-face-inhibit-list'. ;; (cond ;; ((not faces)) ;; ((listp faces) ;; ;; We have a list of face properties. ;; (catch 'found ;; (dolist (face faces t) ;; (when (memq face speck-face-inhibit-list) ;; (throw 'found nil))))) ;; (t ; Atom. ;; (not (memq faces speck-face-inhibit-list)))))))) ;; _____________________________________________________________________________ ;; _ ;;; Process management _ ;; _____________________________________________________________________________ ;; _ (defun speck-filter (process string) "Speck process filter function" (when (buffer-live-p (process-buffer process)) (with-current-buffer (process-buffer process) (save-excursion (goto-char (point-max)) (insert string) ;; No use for it but ... (set-marker (process-mark process) (point)))))) (defun speck-re-start-process (dictionaries-string options) "Return old or new process for current buffer." (or (and (process-live-p speck-process) (or (and (string-equal speck-buffer-dictionaries-string dictionaries-string) (equal speck-buffer-options options) speck-process) (let ((process-buffer (process-buffer speck-process))) ;; Dictionaries or options don't match, kill old ;; process. (delete-process speck-process) (when (buffer-live-p process-buffer) (kill-buffer process-buffer)) (setq speck-process nil)))) (let ((process (make-process :name "speck" :buffer (generate-new-buffer "*speck*") :command (append (list "hunspell" "-a" "-d" dictionaries-string) options) :connection-type 'pipe :filter #'speck-filter :noquery t))) (with-current-buffer (process-buffer process) (setq speck-process-marker (make-marker)) (setq buffer-undo-list t)) ;; Always turn on terse mode - note the newline! (process-send-string process "!\n") (setq speck-process process) (setq speck-buffer-dictionaries-string dictionaries-string) process))) (defun speck-start-process (dictionaries &optional options) "Start Speck process for current buffer." (let ((dictionaries-string (car dictionaries)) process) (setq dictionaries (cdr dictionaries)) (while dictionaries (setq dictionaries-string ;; No space after the comma. (concat dictionaries-string "," (car dictionaries))) (setq dictionaries (cdr dictionaries))) (speck-re-start-process dictionaries-string options))) (defun speck-word (word) "Send a word-like object to `speck-process' and return list of guesses." (let* (guesses process) (unless speck-process ;; THIS SHOULD NOT HAVE HAPPENED (speck-start-process speck-buffer-dictionaries speck-buffer-options)) (setq process speck-process) (with-current-buffer (process-buffer process) (erase-buffer) (process-send-string process (concat "^" word "\n")) (sit-for 0.05) (goto-char (point-min)) (when (re-search-forward ": " nil t) (while (re-search-forward "\\(.*?\\)\\(?:, \\|\n\n\\)" nil t) (setq guesses (cons (match-string-no-properties 1) guesses))) (when guesses (nreverse guesses)))))) (defun speck-run-delay-timer () "Run `speck-delay-timer'. This is an idle timer called each time Emacs has been idle for `speck-delay' seconds." (unless speck-delay-timer (setq speck-delay-timer (run-with-idle-timer speck-delay t 'speck-windows)))) (defun speck-run-pause-timer () "Run `speck-pause-timer'. This is an idle timer called after Emacs has been idle for `speck-pause' seconds. It's activated by `speck-windows'." (unless speck-pause-timer (setq speck-pause-timer (timer-create)) (timer-set-function speck-pause-timer 'speck-windows '(t)))) (defun speck-activate () "Activate specking for current buffer." (unless speck-buffer-dictionaries (setq speck-buffer-dictionaries (or (let* ((entry (assoc 0 speck-dictionaries-alist)) (base (nth 1 entry)) (others (nth 2 entry))) (cons base others)) (list speck-default-dictionary)))) ;; Make this customizable somehow since it overrides a personal ;; dictionary specified via `speck-buffer-options'. (when (and (eq major-mode 'texinfo-mode) buffer-file-name) (let ((spellfile (concat (file-name-directory buffer-file-name) "spellfile"))) (when (file-exists-p spellfile) (setq speck-buffer-options (append speck-buffer-options (list "-p" spellfile)))))) (speck-remove-overlays) (speck-remove-text-properties) (add-hook 'after-change-functions 'speck-after-change nil t) (add-hook 'kill-buffer-hook 'speck-remove-buffer nil t) (add-hook 'window-scroll-functions 'speck-window-scroll nil t) (add-hook 'window-state-change-functions 'speck-window-state-change nil t) (speck-start-process speck-buffer-dictionaries speck-buffer-options) ;; Set up wordchars function (to change it, you have to restart speck ;; in this buffer). (dolist (entry speck-wordchars-alist) (when (string-equal (nth 0 entry) speck-buffer-dictionaries-string) (setq speck-wordchars-regexp (concat "[" (nth 1 entry) "]")) (setq speck-wordchars-function (if (functionp (nth 2 entry)) (nth 2 entry) 'speck-wordchars)))) (speck-add-buffer) (speck-run-delay-timer) (speck-run-pause-timer)) (defun speck-deactivate () "Deactivate specking for current buffer." (setq speck-mode nil) ;; Intentionally do not reset the following. It is used when ;; reactivating Speck in this buffer via `speck-mode'. ;; (setq speck-buffer-dictionaries nil) ;; Remove text properties and overlays. (speck-remove-text-properties) (speck-remove-overlays) (speck-remove-buffer) (remove-hook 'kill-buffer-hook 'speck-remove-buffer t) (remove-hook 'after-change-functions 'speck-after-change t) (remove-hook 'window-scroll-functions 'speck-window-scroll t)) ;;;###autoload (defun speck-buffer (&optional arg) "Toggle `speck-mode' selecting a dictionary. With ARG nil or omitted use the dictionary specifed by `speck-default-dictionary'. With a numeric prefix argument ARG use the corresponding entry from `speck-dictionaries-alist'. Otherwise prompt for a dictionary." (interactive "P") ;; (require 'speck) (let (dictionaries options) (cond ((not arg) (setq dictionaries (list speck-default-dictionary))) ((numberp arg) (let ((entry (assoc arg speck-dictionaries-alist))) (if entry (progn (setq dictionaries (cons (nth 1 entry) (nth 2 entry))) (setq options (nth 3 entry))) (message "No association found for \"%s\"" arg)))) (t (let ((dictionary (completing-read (concat "Enter " (when speck-mode "new ") "dictionary (RET for default, SPC to complete): ") ;; (mapcar 'list (cons "default" speck-base-dictionaries)) speck-base-dictionaries nil t nil speck-dictionaries-history speck-default-dictionary))) (setq dictionaries (list dictionary))))) (when (and (equal dictionaries speck-buffer-dictionaries) (equal options speck-buffer-options)) (message "Buffer dictionaries and options unchanged")) (when speck-mode (speck-deactivate) ;; Hunspell occasionally hangs when restarting, maybe the ;; following helps. (sit-for 0.1)) (setq speck-buffer-dictionaries dictionaries) (setq speck-buffer-options options) (speck-mode))) (defun speck-lighter () "Speck lighter." (propertize (if (stringp speck-mode-line-specking) speck-mode-line-specking (concat " " speck-buffer-dictionaries-string)) 'face (if (memq (selected-window) speck-window-list) 'speck-mode-line-specking 'speck-mode-line-specked))) ;;;###autoload (define-minor-mode speck-mode "Toggle `speck-mode'. With prefix ARG, turn speck-mode on if and only if ARG is positive. Turning on speck-mode will spell-check (\"speck\") all windows showing the current buffer. Global bindings (customizable via `speck-mode-keys'). \\{speck-mode-map}" :group 'speck :init-value nil :lighter (:eval (when speck-lighter (speck-lighter))) :keymap speck-mode-map :require 'speck (if speck-mode (speck-activate) (speck-deactivate))) (provide 'speck)