From 68ee0fba5d939d1056f7803e886bda6b834bf316 Mon Sep 17 00:00:00 2001 From: Alexander Adolf Date: Tue, 19 Jul 2022 22:31:58 +0200 Subject: [PATCH 1/2] Refactoring Message-Completion-Alist * lisp/gnus/message.el (message-completion-alist): alist cdr replaced by plist (message-completion-function): handle new plist cdr type in message-completion-alist, add completion category metadata from message-completion-alist instead of hard coded values (FIXME), use regex from message-completion-alist to determine prefix (message-completion-alist-set-completions): new function to help in writing user init files (message-expand-group): new optional parameters to receive bounds from message-completion-function (message-expand-name): new optional parameters to receive bounds from message-completion-function --- lisp/gnus/message.el | 183 +++++++++++++++++++++++++++++++------------ 1 file changed, 133 insertions(+), 50 deletions(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 00a27fb5f5..07abab4396 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -3180,7 +3180,6 @@ message-mode (mail-abbrevs-setup)) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) - (add-hook 'completion-at-point-functions #'eudc-capf-complete -1 t) (add-hook 'completion-at-point-functions #'message-completion-function nil t) (unless buffer-file-name (message-set-auto-save-file-name)) @@ -8243,14 +8242,68 @@ message-email-recipient-header-regexp :type 'regexp) (defcustom message-completion-alist - `((,message-newgroups-header-regexp . ,#'message-expand-group) - (,message-email-recipient-header-regexp . ,#'message-expand-name)) - "Alist of (RE . FUN). Use FUN for completion on header lines matching RE. -FUN should be a function that obeys the same rules as those -of `completion-at-point-functions'." - :version "27.1" + `((,message-newgroups-header-regexp . (:category newsgroup + :fieldsep-re "\\([:,]\\|^\\)[ \t]*" + :completions ,#'message-expand-group)) + (,message-email-recipient-header-regexp . (:category email + :fieldsep-re "\\([:,]\\|^\\)[ \t]*" + :completions ,#'message-expand-name))) + "Alist of (RE . RECIPE), defining completion contexts. +This variable controls how `message-completion-function' performs +in-buffer completion. RECIPE is either a function (deprecated), +or a plist. + +When `message-completion-function' is invoked, and point is on a +line matching one of the REs in the alist, the settings in the +corresponding RECIPE are applied. + +When RECIPE is a function, it is called for completion. RECIPE +should be a function that obeys the same rules as those of +`completion-at-point-functions'. + +When RECIPE is a plist, the stored properties are used to control +how in-buffer completion is performed. The following properties +are currently defined: + +:category + + The symbol defining the category in + `completion-category-defaults' to use for completion. Also + see `completion-category-overrides', and `completion-styles'. + +:fieldsep-re + + The regular expression to use when scanning backwards in the + buffer. All text between point, and any preceding text + matching this regular expression, will be used as the prefix + for finding completion candidates. + +:completions + + The function that provides completions, and that obeys the + same rules as those of `completion-at-point-functions'. + In-buffer completion will be performed as if + `completion-at-point-functions' had been set to this value." + :version "29.1" :group 'message - :type '(alist :key-type regexp :value-type function)) + :type '(alist :key-type regexp + :value-type (choice (plist) + (function + :tag "Completion function (deprecated)")))) + +(defun message-completion-alist-set-completions (cat compl) + "Set the completion function for category CAT to COMPL. +Modifies the value of `message-completion-alist'. This is a +convenience function for use in init files." + (let ((elt (seq-find (lambda (x) + (eq cat (plist-get (cdr x) :category))) + message-completion-alist))) + (when elt + (setq message-completion-alist + (assoc-delete-all (car elt) message-completion-alist)) + (push (cons (car elt) (plist-put (cdr elt) :completions compl)) + message-completion-alist))) + nil) (defcustom message-expand-name-databases '(bbdb eudc) @@ -8290,6 +8343,13 @@ mail-abbrev-mode-regexp (defvar message--old-style-completion-functions nil) +;; set completion category defaults for categories defined by +;; message mode +(add-to-list 'completion-category-defaults + '(newsgroup (styles substring partial-completion))) +(add-to-list 'completion-category-defaults + '(email (styles substring partial-completion))) + (defun message-completion-function () (let ((alist message-completion-alist)) (while (and alist @@ -8297,43 +8357,62 @@ message-completion-function (not (mail-abbrev-in-expansion-header-p)))) (setq alist (cdr alist))) (when (cdar alist) - (let ((fun (cdar alist))) - (if (member fun message--old-style-completion-functions) - (lambda () - (funcall fun) - ;; Even if completion fails, return a non-nil value, so as to - ;; avoid falling back to message-tab-body-function. - 'completion-attempted) - (let ((ticks-before (buffer-chars-modified-tick)) - (data (funcall fun))) - (if (and (eq ticks-before (buffer-chars-modified-tick)) - (or (null data) - (integerp (car-safe data)))) - data - (push fun message--old-style-completion-functions) - ;; Completion was already performed, so just return a dummy - ;; function that prevents trying any further. - (lambda () 'completion-attempted)))))))) - -(defun message-expand-group () + (let ((recipe (cdar alist))) + (pcase recipe + ((pred functionp) + (if (member recipe message--old-style-completion-functions) + (lambda () + (funcall recipe) + ;; Even if completion fails, return a non-nil value, so as to + ;; avoid falling back to message-tab-body-function. + 'completion-attempted) + (let ((ticks-before (buffer-chars-modified-tick)) + (data (funcall recipe))) + (if (and (eq ticks-before (buffer-chars-modified-tick)) + (or (null data) + (integerp (car-safe data)))) + data + (push recipe message--old-style-completion-functions) + ;; Completion was already performed, so just return a dummy + ;; function that prevents trying any further. + (lambda () 'completion-attempted))))) + (_ + (let* ((completions (plist-get recipe :completions)) + (beg (save-excursion + (re-search-backward (plist-get recipe :fieldsep-re)) + (match-end 0))) + (end (point)) + (cat (plist-get recipe :category)) + completion-table) + (setq completion-table (if (functionp completions) + (funcall completions beg end) + completions)) + ;; TODO: Should we check whether completion-table has + ;; category metadata already, and add it when + ;; missing only? + ;; (setq completion-table + ;; (cons completion-table + ;; `(metadata ((category . ,cat))))) + ;; (message "completion-table = %s" completion-table) + completion-table))))))) + +(defun message-expand-group (&optional pfx-beg pfx-end) "Expand the group name under point." - (let ((b (save-excursion - (save-restriction - (narrow-to-region - (save-excursion - (beginning-of-line) - (skip-chars-forward "^:") - (1+ (point))) - (point)) - (skip-chars-backward "^, \t\n") (point)))) + (let ((b (or pfx-beg (save-excursion + (save-restriction + (narrow-to-region + (save-excursion + (beginning-of-line) + (skip-chars-forward "^:") + (1+ (point))) + (point)) + (skip-chars-backward "^, \t\n") (point))))) (completion-ignore-case t) - (e (progn (skip-chars-forward "^,\t\n ") (point))) + (e (or pfx-end (progn (skip-chars-forward "^,\t\n ") (point)))) (collection (when (and (boundp 'gnus-active-hashtb) gnus-active-hashtb) (hash-table-keys gnus-active-hashtb)))) (when collection - ;; FIXME: Add `category' metadata to the collection, so we can use - ;; substring matching on it. (list b e collection)))) (defcustom message-expand-name-standard-ui nil @@ -8346,14 +8425,16 @@ message-expand-name-standard-ui :version "27.1" :type 'boolean) -(defun message-expand-name () +(defun message-expand-name (&optional pfx-beg pfx-end) (cond (message-expand-name-standard-ui - (let ((beg (save-excursion - (skip-chars-backward "^\n:,") (skip-chars-forward " \t") - (point))) - (end (save-excursion - (skip-chars-forward "^\n,") (skip-chars-backward " \t") - (point)))) + (let ((beg (or pfx-beg (save-excursion + (skip-chars-backward "^\n:,") + (skip-chars-forward " \t") + (point)))) + (end (or pfx-end (save-excursion + (skip-chars-forward "^\n,") + (skip-chars-backward " \t") + (point))))) (when (< beg end) (list beg end (message--name-table (buffer-substring beg end)))))) ((and (memq 'eudc message-expand-name-databases) @@ -8371,9 +8452,6 @@ message-expand-name (t (expand-abbrev)))) -(add-to-list 'completion-category-defaults '(email (styles substring - partial-completion))) - (defun message--bbdb-query-with-words (words) ;; FIXME: This (or something like this) should live on the BBDB side. (when (fboundp 'bbdb-records) @@ -8401,7 +8479,12 @@ message--name-table bbdb-responses) (lambda (string pred action) (pcase action - ('metadata '(metadata (category . email))) + ('metadata (let* ((recipe (alist-get message-email-recipient-header-regexp + message-completion-alist)) + (cat (plist-get recipe :category))) + (pcase recipe + ((pred functionp) '(metadata (category . email))) + (_ (when cat `(metadata (category . ,cat))))))) ('lambda t) ((or 'nil 't) (when orig-words -- 2.37.1