Re: Thoughts on Refactoring In-Buffer Completion In message.el

[Alexander Adolf <alexander.adolf@condition-alpha.com>]

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

Hello Stefan,

Many thanks for your swift response, and helpful comments!

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

> [...]
> `group` is too generic a name (remember that those category names are
> "global" so they should be meaning in any other context than
> message.el).
> `newsgroup` maybe?

Good point; 'newsgroup' it is.

>> +: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."
>
> I think this should be a completion table, not a CAPF function.

Why restrict it to a table? Perhaps we should allow both, functions and
tables? Practically, that could mean checking whether the value
satisfies `functionp`, and `funcall` it when that's the case; else use
it as a ready-made table.

It seems I am missing something?

>> +          (_
>> +           (let* ((recipe (alist-get message-email-recipient-header-regexp
>> +                                     message-completion-alist))
>> +                  (completions-function (plist-get recipe :completions)))
>> +             (funcall completions-function))))))))
>
> Hmm... `recipe` should be (car alist), rather than this
> weird (alist-get ...), no?

I confused myself (and apparently you, too). `recipe` is one and the
same as `fun`; no need for an extra variable.

> And then we should do the (skip-chars-forw/backward "^, \t\n") dance
> here, 

Added in the updated patch at the end of this message.

> as well as the metadata dance to add the `category` if specified by
> `recipe`.

Good point. I amended `message-completion-function` to add a metadata
property with category information.

> [...]
> Tho, now that I think about it, having those styles in
> `message-completion-alist` is weird: that var is a `defcustom`, hence
> a user setting, yet we put it into `completion-category-defaults` which
> is not meant to contain user settings (that's what
> `completion-category-overrides` is for).
>
> So maybe we should just hardcode
>
>     (add-to-list 'completion-category-defaults
>                  '(newsgroup (styles substring partial-completion))))
>     (add-to-list 'completion-category-defaults
>                  '(email (styles substring partial-completion))))
>
> and remove the `:styles` from `message-completion-alist` since the user
> should set `completion-category-overrides` instead.

I agree. I hadn't viewed completion-category-defaults as the global
setting it actually is.

Below is the updated patch.

I have made minimally invasive modifications only to
message-expand-name, and message-expand-group. Frankly, my goal is to
not have a message-expand-name at all, but to call some eudc-capf-*
function directly for email addresses.

I also have not added any checking whether individual properties are
present in the plist, or not. What would be the use-case for not
specifying any of the three?


Looking forward to your thoughts,

  --alexander


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Refactoring-Message-Completion-Alist.patch --]
[-- Type: text/x-patch, Size: 11474 bytes --]

From 87a6778db682395f61b87b629c9553ff90059902 Mon Sep 17 00:00:00 2001
From: Alexander Adolf <alexander.adolf@condition-alpha.com>
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, 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 | 180 +++++++++++++++++++++++++++++++------------
 1 file changed, 130 insertions(+), 50 deletions(-)

diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 7c2b24c6ee..da63e3441d 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,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)
@@ -8291,6 +8344,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
@@ -8298,43 +8358,59 @@ 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 (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))))))))))))
+
+(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
@@ -8347,14 +8423,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)
@@ -8372,9 +8450,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)
@@ -8402,7 +8477,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