Make MH-E use completion-at-point

[bpt/emacs.git] / lisp / mh-e / mh-letter.el

diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el
index eebc30a..2ced886 100644 (file)
--- a/lisp/mh-e/mh-letter.el
+++ b/lisp/mh-e/mh-letter.el
@@ -185,7 +185,7 @@ semi-obsolete and is only used if `mail-citation-hook' is nil.")
   "\C-c\C-w"            mh-check-whom
   "\C-c\C-y"            mh-yank-cur-msg
   "\C-c\M-d"            mh-insert-auto-fields
-  "\M-\t"               mh-letter-complete
+  "\M-\t"               mh-letter-complete ;; FIXME: completion-at-point
   "\t"                  mh-letter-next-header-field-or-indent
   [backtab]             mh-letter-previous-header-field)
 
@@ -346,6 +346,8 @@ order).
   (define-key mh-letter-mode-map [menu-bar mail] 'undefined)
   (mh-do-in-xemacs (easy-menu-remove mail-menubar-menu))
   (setq fill-column mh-letter-fill-column)
+  (add-hook 'completion-at-point-functions
+            'mh-letter-completion-at-point nil 'local)
   ;; If text-mode-hook turned on auto-fill, tune it for messages
   (when auto-fill-function
     (make-local-variable 'auto-fill-function)
@@ -488,24 +490,38 @@ In a program, you can pass in a signature FILE."
             (message "No signature found")))))
   (force-mode-line-update))
 
-(defun mh-letter-complete (arg)
-  "Perform completion on header field or word preceding point.
+(defun mh-letter-completion-at-point ()
+  "Return the completion data at point for MH letters.
+This provides alias and folder completion in header fields according to
+`mh-letter-complete-function-alist' and falls back on
+`mh-letter-complete-function-alist' elsewhere."
+  (let ((func (and (mh-in-header-p)
+                   (cdr (assoc (mh-letter-header-field-at-point)
+                               mh-letter-complete-function-alist)))))
+    (if func
+        (or (funcall func) #'ignore)
+      mh-letter-complete-function)))
+
+(defalias 'mh-letter-complete
+  (if (fboundp 'completion-at-point) #'completion-at-point
+    (lambda ()
+      "Perform completion on header field or word preceding point.
 
 If the field contains addresses (for example, \"To:\" or \"Cc:\")
 or folders (for example, \"Fcc:\") then this command will provide
 alias completion. In the body of the message, this command runs
 `mh-letter-complete-function' instead, which is set to
-`ispell-complete-word' by default. This command takes a prefix
-argument ARG that is passed to the
-`mh-letter-complete-function'."
-  (interactive "P")
-  (let ((func nil))
-    (cond ((not (mh-in-header-p))
-           (funcall mh-letter-complete-function arg))
-          ((setq func (cdr (assoc (mh-letter-header-field-at-point)
-                                  mh-letter-complete-function-alist)))
-           (funcall func))
-          (t (funcall mh-letter-complete-function arg)))))
+`ispell-complete-word' by default."
+      (interactive)
+      (let ((data (mh-letter-completion-at-point)))
+        (cond
+         ((functionp data) (funcall data))
+         ((consp data)
+          (let ((start (nth 0 data))
+                (end (nth 1 data))
+                (table (nth 2 data)))
+            (mh-complete-word (buffer-substring-no-properties start end)
+                              table start end))))))))
 
 (defun mh-letter-complete-or-space (arg)
   "Perform completion or insert space.
@@ -521,11 +537,12 @@ one space."
                        (mh-beginning-of-word -1))))
     (cond ((not mh-compose-space-does-completion-flag)
            (self-insert-command arg))
-          ((not (mh-in-header-p)) (self-insert-command arg))
+          ;; FIXME: This > test is redundant now that all the completion
+          ;; functions do it anyway.
           ((> (point) end-of-prev) (self-insert-command arg))
-          ((setq func (cdr (assoc (mh-letter-header-field-at-point)
-                                  mh-letter-complete-function-alist)))
-           (funcall func))
+          ((let ((mh-letter-complete-function nil))
+             (mh-letter-completion-at-point))
+           (mh-letter-complete))
           (t (self-insert-command arg)))))
 
 (defun mh-letter-confirm-address ()
@@ -862,18 +879,17 @@ downcasing the field name."
 
 (defun mh-folder-expand-at-point ()
   "Do folder name completion in Fcc header field."
-  (let* ((end (point))
-         (beg (mh-beginning-of-word))
-         (folder (buffer-substring-no-properties beg end))
-         (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+)))
-         (choices (mapcar (lambda (x) (list x))
-                          (mh-folder-completion-function folder nil t))))
-    (unless leading-plus
-      (setq folder (concat "+" folder)))
-    (mh-complete-word folder choices beg end)))
+  (let* ((beg (mh-beginning-of-word))
+         (end (save-excursion
+                (goto-char beg)
+                (mh-beginning-of-word -1))))
+    (when (>= end (point))
+      (list beg (if (fboundp 'completion-at-point) end (point))
+            #'mh-folder-completion-function))))
 
 ;;;###mh-autoload
 (defun mh-complete-word (word choices begin end)
+  ;; FIXME: Only needed when completion-at-point doesn't exist.
   "Complete WORD from CHOICES.
 Any match found replaces the text from BEGIN to END."
   (let ((completion (try-completion word choices))
@@ -889,8 +905,16 @@ Any match found replaces the text from BEGIN to END."
           ((stringp completion)
            (if (equal word completion)
                (with-output-to-temp-buffer completions-buffer
-                 (mh-display-completion-list (all-completions word choices)
-                                             word))
+                 (mh-display-completion-list
+                  (all-completions word choices)
+                  ;; The `common-subtring' arg only works if it's a prefix.
+                  (unless (and (functionp choices)
+                               (let ((bounds
+                                      (funcall choices
+                                               word nil '(boundaries . ""))))
+                                 (and (eq 'boundaries (car-safe bounds))
+                                      (< 0 (cadr bounds)))))
+                    word)))
              (ignore-errors
                (kill-buffer completions-buffer))
              (delete-region begin end)