[Emacs-diffs] /srv/bzr/emacs/trunk r104037: Make MH-E use completion-at-point

[Stefan Monnier]

------------------------------------------------------------
revno: 104037
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Thu 2011-04-28 12:32:28 -0300
message:
  Make MH-E use completion-at-point
  * lisp/mh-e/mh-letter.el (mh-letter-completion-at-point): New function,
  extracted from mh-letter-complete
  (mh-letter-mode, mh-letter-complete, mh-letter-complete-or-space): Use it.
  (mh-complete-word): Only use the common-substring arg when it works.
  (mh-folder-expand-at-point):
  * lisp/mh-e/mh-alias.el (mh-alias-letter-expand-alias): Return data suitable
  for completion-at-point-functions.
  * lisp/mh-e/mh-utils.el (mh-folder-completion-function): Make it work like
  file-name completion, so partial-completion can do its job.
  * lisp/minibuffer.el (completion-at-point, completion-help-at-point):
  Don't presume that a given completion-at-point-function will always
  use the same calling convention.
modified:
  lisp/mh-e/ChangeLog
  lisp/mh-e/mh-alias.el
  lisp/mh-e/mh-e.el
  lisp/mh-e/mh-letter.el
  lisp/mh-e/mh-utils.el
  lisp/minibuffer.el

=== modified file 'lisp/mh-e/ChangeLog'
--- a/lisp/mh-e/ChangeLog       2011-04-06 12:18:10 +0000
+++ b/lisp/mh-e/ChangeLog       2011-04-28 15:32:28 +0000
@@ -1,3 +1,17 @@
+2011-04-28  Stefan Monnier  <address@hidden>
+
+       * mh-utils.el (mh-folder-completion-function): Make it work like
+       file-name completion, so partial-completion can do its job.
+
+       * mh-letter.el (mh-letter-completion-at-point): New function, extracted
+       from mh-letter-complete
+       (mh-letter-mode, mh-letter-complete, mh-letter-complete-or-space):
+       Use it.
+       (mh-complete-word): Only use the common-substring arg when it works.
+       (mh-folder-expand-at-point):
+       * mh-alias.el (mh-alias-letter-expand-alias): Return data suitable for
+       completion-at-point-functions.
+
 2011-04-06  Juanma Barranquero  <address@hidden>
 
        * mh-funcs.el (mh-undo-folder): Accept and ignore arguments,

=== modified file 'lisp/mh-e/mh-alias.el'
--- a/lisp/mh-e/mh-alias.el     2011-01-26 08:36:39 +0000
+++ b/lisp/mh-e/mh-alias.el     2011-04-28 15:32:28 +0000
@@ -296,16 +296,28 @@
 (defun mh-alias-letter-expand-alias ()
   "Expand mail alias before point."
   (mh-alias-reload-maybe)
-  (let* ((end (point))
-         (begin (mh-beginning-of-word))
-         (input (buffer-substring-no-properties begin end)))
-    (mh-complete-word input mh-alias-alist begin end)
-    (when mh-alias-expand-aliases-flag
-      (let* ((end (point))
-             (expansion (mh-alias-expand (buffer-substring begin end))))
-        (delete-region begin end)
-        (insert expansion)))))
-
+  (let* ((begin (mh-beginning-of-word))
+         (end (save-excursion
+                (goto-char begin)
+                (mh-beginning-of-word -1))))
+    (when (>= end (point))
+      (list
+       begin (if (fboundp 'completion-at-point) end (point))
+       (if (not mh-alias-expand-aliases-flag)
+           mh-alias-alist
+         (lambda (string pred action)
+           (case action
+             ((nil)
+              (let ((res (try-completion string mh-alias-alist pred)))
+                (if (or (eq res t)
+                        (and (stringp res)
+                             (eq t (try-completion res mh-alias-alist pred))))
+                    (or (mh-alias-expand (if (stringp res) res string))
+                        res)
+                  res)))
+             ((t) (all-completions string mh-alias-alist pred))
+             ((lambda) (if (fboundp 'test-completion)
+                      (test-completion string mh-alias-alist pred))))))))))
 
 
 ;;; Alias File Updating

=== modified file 'lisp/mh-e/mh-e.el'
--- a/lisp/mh-e/mh-e.el 2011-01-25 04:08:28 +0000
+++ b/lisp/mh-e/mh-e.el 2011-04-28 15:32:28 +0000
@@ -1179,7 +1179,7 @@
   "*Non-nil means to expand aliases entered in the minibuffer.
 
 In other words, aliases entered in the minibuffer will be
-expanded to the full address in the message draft. By default,
+expanded to the full address in the message draft.  By default,
 this expansion is not performed."
   :type 'boolean
   :group 'mh-alias

=== modified file 'lisp/mh-e/mh-letter.el'
--- a/lisp/mh-e/mh-letter.el    2011-01-26 08:36:39 +0000
+++ b/lisp/mh-e/mh-letter.el    2011-04-28 15:32:28 +0000
@@ -185,7 +185,7 @@
   "\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 @@
   (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 @@
             (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 @@
                        (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 @@
 
 (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 @@
           ((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)

=== modified file 'lisp/mh-e/mh-utils.el'
--- a/lisp/mh-e/mh-utils.el     2011-01-26 08:36:39 +0000
+++ b/lisp/mh-e/mh-utils.el     2011-04-28 15:32:28 +0000
@@ -596,6 +596,7 @@
                   (setq name (substring name 0 (1- (length name)))))
                 (push
                  (cons name
+                       ;; FIXME: what is this used for?  --Stef
                        (search-forward "(others)" (mh-line-end-position) t))
                  results))))
           (forward-line 1))))
@@ -702,32 +703,33 @@
          (remainder (cond (last-complete (substring name (1+ last-slash)))
                           (name (substring name 1))
                           (t ""))))
-    (cond ((eq flag nil)
+    (cond ((eq (car-safe flag) 'boundaries)
+           (list* 'boundaries
+                  (let ((slash (mh-search-from-end ?/ orig-name)))
+                    (if slash (1+ slash)
+                      (if (string-match "\\`\\+" orig-name) 1 0)))
+                  (if (cdr flag) (string-match "/" (cdr flag)))))
+          ((eq flag nil)
            (let ((try-res
                   (try-completion
-                   name
-                   (mapcar (lambda (x)
-                             (cons (concat (or last-complete "+") (car x))
-                                   (cdr x)))
-                    (mh-sub-folders last-complete t))
+                   remainder
+                   (mh-sub-folders last-complete t)
                    predicate)))
              (cond ((eq try-res nil) nil)
                    ((and (eq try-res t) (equal name orig-name)) t)
                    ((eq try-res t) name)
-                   (t try-res))))
+                   (t (concat (or last-complete "+") try-res)))))
           ((eq flag t)
-           (mapcar (lambda (x)
-                     (concat (or last-complete "+") x))
-                   (all-completions
-                    remainder (mh-sub-folders last-complete t) predicate)))
+           (all-completions
+            remainder (mh-sub-folders last-complete t) predicate))
           ((eq flag 'lambda)
            (let ((path (concat (unless (and (> (length name) 1)
                                             (eq (aref name 1) ?/))
                                  mh-user-path)
                                (substring name 1))))
-             (cond (mh-allow-root-folder-flag (file-exists-p path))
+             (cond (mh-allow-root-folder-flag (file-directory-p path))
                    ((equal path mh-user-path) nil)
-                   (t (file-exists-p path))))))))
+                   (t (file-directory-p path))))))))
 
 ;; Shush compiler.
 (defvar completion-root-regexp)          ; XEmacs

=== modified file 'lisp/minibuffer.el'
--- a/lisp/minibuffer.el        2011-04-23 03:07:16 +0000
+++ b/lisp/minibuffer.el        2011-04-28 15:32:28 +0000
@@ -1377,6 +1377,10 @@
   "List of well-behaved functions found on `completion-at-point-functions'.")
 
 (defun completion--capf-wrapper (fun which)
+  ;; FIXME: The safe/misbehave handling assumes that a given function will
+  ;; always return the same kind of data, but this breaks down with functions
+  ;; like comint-completion-at-point or mh-letter-completion-at-point, which
+  ;; could be sometimes safe and sometimes misbehaving (and sometimes neither).
   (if (case which
         (all t)
         (safe (member fun completion--capf-safe-funs))
@@ -1408,7 +1412,7 @@
              (completion-in-region-mode-predicate
               (lambda ()
                 ;; We're still in the same completion field.
-                (eq (car (funcall hookfun)) start))))
+                (eq (car-safe (funcall hookfun)) start))))
         (completion-in-region start end collection
                               (plist-get plist :predicate))))
      ;; Maybe completion already happened and the function returned t.
@@ -1433,7 +1437,7 @@
              (completion-in-region-mode-predicate
               (lambda ()
                 ;; We're still in the same completion field.
-                (eq (car (funcall hookfun)) start)))
+                (eq (car-safe (funcall hookfun)) start)))
              (ol (make-overlay start end nil nil t)))
         ;; FIXME: We should somehow (ab)use completion-in-region-function or
         ;; introduce a corresponding hook (plus another for word-completion,