From: Stefan Monnier Date: Thu, 12 Dec 2019 01:17:17 +0000 (-0500) Subject: * lisp/gnus/message.el (message-expand-name-standard-ui): New option X-Git-Tag: emacs-27.0.90~376 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=47a767c24e9cc4323432e29103b0a2cc46f8f3e4;p=emacs.git * lisp/gnus/message.el (message-expand-name-standard-ui): New option (message--old-style-completion-functions): New var. (message-completion-function): Allow functions on `message-completion-alist` to follow the capf protocol. (message-completion-alist): Adjust docstring accordingly. Simplify regexps and make them apply more liberally. (message-expand-group): Use the capf protocol. (completion-category-defaults): Use 'substring' completion style by default for email addresses. (message--bbdb-query-with-words, message--name-table): New functions. (message-expand-name): Use them to obey `message-expand-name-standard-ui`. --- diff --git a/etc/NEWS b/etc/NEWS index 7602a2e56a1..4df123d787b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1961,6 +1961,12 @@ GnuTLS manual) is recommended instead. ** Message +*** Completion of email addresses can use the standard completion UI +This is controlled by 'message-expand-name-standard-ui'. +With the standard UI the different sources (ecomplete, bbdb, and eudc) +are matched together and try to obey 'completion-styles'. +It should work for other completion front ends like Company. + *** 'message-mode' now supports highlighting citations of different depths. This can be customized via the new user option 'message-cite-level-function' and the new 'message-cited-text-*' faces. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 6778f0e661d..f7f5e9dd344 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -8043,15 +8043,12 @@ When FORCE, rebuild the tool bar." :type 'regexp) (defcustom message-completion-alist - ;; FIXME: Make it possible to use the standard completion UI. - (list (cons message-newgroups-header-regexp 'message-expand-group) - '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name) - '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" - . message-expand-name) - '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):" - . message-expand-name)) - "Alist of (RE . FUN). Use FUN for completion on header lines matching RE." - :version "22.1" + `((,message-newgroups-header-regexp . ,#'message-expand-group) + ("^\\([^ :]*-\\)?\\(To\\|B?Cc\\|From\\):" . ,#'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" :group 'message :type '(alist :key-type regexp :value-type function)) @@ -8091,6 +8088,8 @@ regular text mode tabbing command." (defvar mail-abbrev-mode-regexp) +(defvar message--old-style-completion-functions nil) + (defun message-completion-function () (let ((alist message-completion-alist)) (while (and alist @@ -8099,9 +8098,22 @@ regular text mode tabbing command." (setq alist (cdr alist))) (when (cdar alist) (let ((fun (cdar alist))) - ;; Even if completion fails, return a non-nil value, so as to avoid - ;; falling back to message-tab-body-function. - (lambda () (funcall fun) 'completion-attempted))))) + (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 () "Expand the group name under point." @@ -8120,10 +8132,27 @@ regular text mode tabbing command." gnus-active-hashtb) (hash-table-keys gnus-active-hashtb)))) (when collection - (completion-in-region b e 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 + "If non-nil, use the standard completion UI in `message-expand-name'. +E.g. this means it will obey `completion-styles' and other such settings." + :version "27.1" + :type 'boolean) (defun message-expand-name () - (cond ((and (memq 'eudc message-expand-name-databases) + (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)))) + (when (< beg end) + (list beg end (message--name-table (buffer-substring beg end)))))) + ((and (memq 'eudc message-expand-name-databases) (boundp 'eudc-protocol) eudc-protocol) (eudc-expand-inline)) @@ -8138,6 +8167,58 @@ regular text mode tabbing command." (t (expand-abbrev)))) +(add-to-list 'completion-category-defaults '(email (styles substring))) + +(defun message--bbdb-query-with-words (words) + ;; FIXME: This (or something like this) should live on the BBDB side. + (when (fboundp 'bbdb-records) + (require 'bbdb) ;FIXME: `bbdb-records' is incorrectly autoloaded! + (bbdb-records) ;Make sure BBDB and its database is initialized. + (defvar bbdb-hashtable) + (declare-function bbdb-record-mail "bbdb" (record)) + (declare-function bbdb-dwim-mail "bbdb-com" (record &optional mail)) + (declare-function bbdb-completion-predicate "bbdb-com" (key records)) + (let ((records '()) + (responses '())) + (dolist (word words) + (dolist (c (all-completions word bbdb-hashtable + #'bbdb-completion-predicate)) + (dolist (record (gethash c bbdb-hashtable)) + (cl-pushnew record records)))) + (dolist (record records) + (dolist (mail (bbdb-record-mail record)) + (push (bbdb-dwim-mail record mail) responses))) + responses))) + +(defun message--name-table (orig-string) + (let ((orig-words (split-string orig-string "[ \t]+")) + eudc-responses + bbdb-responses) + (lambda (string pred action) + (pcase action + ('metadata '(metadata (category . email))) + ('lambda t) + ((or 'nil 't) + (when orig-words + (when (and (memq 'eudc message-expand-name-databases) + (boundp 'eudc-protocol) + eudc-protocol) + (setq eudc-responses (eudc-query-with-words orig-words))) + (when (memq 'bbdb message-expand-name-databases) + (setq bbdb-responses (message--bbdb-query-with-words orig-words))) + (ecomplete-setup) + (setq orig-words nil)) + (let ((candidates + ;; FIXME: Add `expand-abbrev'! + (append (all-completions string eudc-responses pred) + (all-completions string bbdb-responses pred) + (when (and (bound-and-true-p ecomplete-database) + (fboundp 'ecomplete-completion-table)) + (all-completions string + (ecomplete-completion-table 'mail) + pred))))) + (if action candidates (try-completion string candidates)))))))) + ;;; Help stuff. (defun message-talkative-question (ask question show &rest text)