Re: Completion functions in message-mode

[Eric Abrahamsen <eric@ericabrahamsen.net>]

[-- Attachment #1: Type: text/plain, Size: 1398 bytes --]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

>> My next question is, how does one "extend" a completion table?
>
> Not sure what you mean, but you can combine completion tables for
> example by using completion-table-in-turn, or by doing something
> similar to what it does.

Yes, that's what I meant.

>> Specifically: if c-a-p expects to receive (START END COLLECTION), should
>                                                        ^^^^^^^^^^
> BTW, this is what I call "completion table".

Right, that much I understood. But otherwise I was very undereducated
about how completion works, and so have gone down some rabbit holes in
the course of writing the attached patch, which is underwhelming for how
long it took me.

I doubt this will be acceptable as-is, but I do hope it will get us (me)
a step closer. What I ended up with was an option,
`message-expand-name-tables', that contact-management/addressbook
packages can add completion tables to. This is very simple, but probably
too simple: it leaves no mechanism for these packages to add extra PROPS
data, like :predicate or :annotation, and also doesn't give them the
opportunity to alter START and END (though maybe it shouldn't?).

Anyway, for what it is, it works. It also add six spurious blank spaces
to the end of any completion, at least in my test setup, but who's
counting!?

Hopefully we can go somewhere from here.



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: message-completion.diff --]
[-- Type: text/x-patch, Size: 6872 bytes --]

diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 33c5e2cedb..3a8e3f6e0f 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -7929,24 +7929,33 @@ message-make-tool-bar
 				    'message-mode-map))))
   message-tool-bar-map)
 
-;;; Group name completion.
+;;; Group and mail name completion.
 
 (defcustom message-newgroups-header-regexp
   "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
-  "Regexp that match headers that lists groups."
+  "Regexp matching headers that list groups."
   :group 'message
   :type 'regexp)
 
+(defcustom message-mail-header-regexp
+  (concat
+   "^"
+   (regexp-opt
+    '("To" "Bcc" "Cc" "Resent-To" "Resent-Bcc" "Resent-Cc"
+      "Reply-To" "From" "Mail-Followup-To" "Mail-Copies-To"
+      "Disposition-Notification-To" "Return-Receipt-To"))
+   ":")
+  "Regexp matching headers that list name/mail addresses."
+  :group 'message
+  :type 'regexp
+  :version "27.1")
+
 (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"
+  (list (cons message-newgroups-header-regexp #'message-expand-group)
+	(cons message-mail-header-regexp #'message-expand-name))
+  "Alist of (RE . FUN).
+Use FUN for completion on header lines matching RE."
+  :version "27.1"
   :group 'message
   :type '(alist :key-type regexp :value-type function))
 
@@ -7956,6 +7965,19 @@ message-expand-name-databases
 Each element is a symbol and can be `bbdb' or `eudc'."
   :group 'message
   :type '(set (const bbdb) (const eudc)))
+(make-obsolete-variable
+ 'message-expand-name-databases
+ "Add completion tables to `message-expand-name-tables' instead"
+ "27.1")
+
+(defcustom message-expand-name-tables nil
+  "List of tables that can be used to expand names.
+Each \"table\" is a collection containing potential expansions,
+and can be an alist, a plain list, a hash table, an obarray, or a
+function.  Multiple tables will be merged."
+  :group 'message
+  :version "27.1"
+  :type 'list)
 
 (defcustom message-tab-body-function nil
   "Function to execute when `message-tab' (TAB) is executed in the body.
@@ -7982,24 +8004,16 @@ message-tab
    (message-tab-body-function (funcall message-tab-body-function))
    (t (funcall (or (lookup-key text-mode-map "\t")
                    (lookup-key global-map "\t")
-                   'indent-relative)))))
+                   #'indent-relative)))))
 
 (defvar mail-abbrev-mode-regexp)
 
-(defun message-completion-function ()
-  (let ((alist message-completion-alist))
-    (while (and alist
-		(let ((mail-abbrev-mode-regexp (caar alist)))
-		  (not (mail-abbrev-in-expansion-header-p))))
-      (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)))))
+(defvar message--old-style-completion-functions nil)
 
-(defun message-expand-group ()
-  "Expand the group name under point."
+(defsubst message-header-completion-bounds ()
+  "Return the bounds of header input for completion.
+Searches back for either the end of header or the nearest comma,
+and forward for either the nearest comma or EOL."
   (let ((b (save-excursion
 	     (save-restriction
 	       (narrow-to-region
@@ -8009,36 +8023,57 @@ message-expand-group
 		  (1+ (point)))
 		(point))
 	       (skip-chars-backward "^, \t\n") (point))))
-	(completion-ignore-case t)
-	(e (progn (skip-chars-forward "^,\t\n ") (point)))
-	group collection)
-    (when (and (boundp 'gnus-active-hashtb)
-	       gnus-active-hashtb)
-      (mapatoms
-       (lambda (symbol)
-	 (setq group (symbol-name symbol))
-	 (push (if (string-match "[^\000-\177]" group)
-		   (gnus-group-decoded-name group)
-		 group)
-	       collection))
-       gnus-active-hashtb))
-    (completion-in-region b e collection)))
+	(e (progn (skip-chars-forward "^,\t\n ") (point))))
+    (cons b e)))
+
+(defun message-completion-function ()
+  "Possibly complete a group name or mail address.
+Check if point is in an appropriate header for completion,
+otherwise return nil."
+  (let ((alist message-completion-alist))
+    (while (and alist
+		(let ((mail-abbrev-mode-regexp (caar alist)))
+		  (not (mail-abbrev-in-expansion-header-p))))
+      (setq alist (cdr alist)))
+    (when (cdar alist)
+      (let ((fun (cdar alist))
+	    (completion-ignore-case t))
+	(if (member fun message--old-style-completion-functions)
+	    ;; 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)
+	  (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 ()
+  "Return group completion from `gnus-active-hashtb'."
+  (pcase-let ((`(,b . ,e) (message-header-completion-bounds)))
+    (let (collection group)
+     (when (and (boundp 'gnus-active-hashtb)
+		gnus-active-hashtb)
+       (mapatoms
+	(lambda (symbol)
+	  (setq group (symbol-name symbol))
+	  (push (if (string-match "[^\000-\177]" group)
+		    (gnus-group-decoded-name group)
+		  group)
+		collection))
+	gnus-active-hashtb)
+       (list b e collection)))))
 
 (defun message-expand-name ()
-  (cond ((and (memq 'eudc message-expand-name-databases)
-		    (boundp 'eudc-protocol)
-		    eudc-protocol)
-	 (eudc-expand-inline))
-	((and (memq 'bbdb message-expand-name-databases)
-	      (fboundp 'bbdb-complete-name))
-         (let ((starttick (buffer-modified-tick)))
-           (or (bbdb-complete-name)
-               ;; Apparently, bbdb-complete-name can return nil even when
-               ;; completion took place.  So let's double check the buffer was
-               ;; not modified.
-               (/= starttick (buffer-modified-tick)))))
-	(t
-	 (expand-abbrev))))
+  (pcase-let ((`(,b . ,e) (message-header-completion-bounds)))
+    (when message-expand-name-tables
+      (list b e (apply #'completion-table-in-turn
+		       message-expand-name-tables)))))
 
 ;;; Help stuff.