From d7b4fbed9c34b7c73d59d8f709934a548c109149 Mon Sep 17 00:00:00 2001 From: Alexander Adolf Date: Tue, 19 Jul 2022 22:31:58 +0200 Subject: [PATCH] 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 (message-expand-group): add completion category metadata (FIXME) (completion-category-defaults): set group category and its defaults from message-completion-alist (completion-category-defaults): set email category and its defaults from message-completion-alist instead of hard coded values (message--name-table): set category metadata from message-completion-alist instead of hard coded values --- lisp/gnus/message.el | 137 +++++++++++++++++++++++++++++++++---------- 1 file changed, 107 insertions(+), 30 deletions(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 7c2b24c6ee..3dafc89970 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)) @@ -8244,14 +8243,51 @@ 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 group + :styles (substring partial-completion) + :completions ,#'message-expand-group)) + (,message-email-recipient-header-regexp . (:category email + :styles (substring partial-completion) + :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'. + +:styles + + The list of `completion-styles' to use for that category. + +: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)")))) (defcustom message-expand-name-databases '(bbdb eudc) @@ -8299,22 +8335,29 @@ message-completion-function (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)))))))) + (pcase fun + ((pred functionp) + (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))))) + (_ + (let* ((recipe (alist-get message-email-recipient-header-regexp + message-completion-alist)) + (completions-function (plist-get recipe :completions))) + (funcall completions-function)))))))) (defun message-expand-group () "Expand the group name under point." @@ -8333,9 +8376,28 @@ message-expand-group 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)))) + (let ((res (list b e collection)) + (cat (plist-get (alist-get + message-newgroups-header-regexp + message-completion-alist) + :category))) + (when cat + (setq res (cons res `(metadata ((category . ,cat)))))) + res) + ))) + +;; set completion category defaults for newsgroup names based the on +;; settings in `message-completion-alist' +(let ((recipe (alist-get message-newgroups-header-regexp + message-completion-alist))) + (pcase recipe + ((pred functionp) + (add-to-list 'completion-category-defaults + '(group (styles substring partial-completion)))) + (_ + (add-to-list 'completion-category-defaults + `(,(plist-get recipe :category) + (styles ,@(plist-get recipe :styles))))))) (defcustom message-expand-name-standard-ui nil "If non-nil, use the standard completion UI in `message-expand-name'. @@ -8372,8 +8434,18 @@ message-expand-name (t (expand-abbrev)))) -(add-to-list 'completion-category-defaults '(email (styles substring - partial-completion))) +;; set completion category defaults for email addresses based the on +;; settings in `message-completion-alist' +(let ((recipe (alist-get message-email-recipient-header-regexp + message-completion-alist))) + (pcase recipe + ((pred functionp) + (add-to-list 'completion-category-defaults + '(email (styles substring partial-completion)))) + (_ + (add-to-list 'completion-category-defaults + `(,(plist-get recipe :category) + (styles ,@(plist-get recipe :styles))))))) (defun message--bbdb-query-with-words (words) ;; FIXME: This (or something like this) should live on the BBDB side. @@ -8402,7 +8474,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.0