bug#46091: ido: Add support for tab completion using an alist collection.

[Keith David Bershatsky]

Currently, ido does not support tab completion using an alist collection.

(require 'ido)

(let* ((alist '(("pine" . "cones")
                ("oak" . "acorns")
                ("maple" . "seeds")))
       (choice (ido-completing-read "CHOOSE:  " alist nil 'confirm)))
  (cdr (assoc choice alist)))

;;; Debugger entered--Lisp error: (wrong-type-argument listp "seeds")
;;;   ido-no-final-slash(("maple" . "seeds"))
;;;   ido-file-lessp(("maple" . "seeds") ("oak" . "acorns"))
;;;   sort((("pine" . "cones")) ido-file-lessp)
;;;   ido-completion-help()
;;;   funcall-interactively(ido-completion-help)
;;;   call-interactively(ido-completion-help)
;;;   ido-complete()
;;;   funcall-interactively(ido-complete)
;;;   call-interactively(ido-complete nil nil)
;;;   command-execute(ido-complete)
;;;   read-from-minibuffer("CHOOSE:  " nil (keymap keymap (4 . 
ido-magic-delete-char) (6 . ido-magic-forward-char) (2 . 
ido-magic-backward-char) (63 . ido-completion-help) (left . ido-prev-match) 
(right . ido-next-match) (0 . ido-restrict-to-matches) (27 keymap (32 . 
ido-take-first-match)) (67108896 . ido-restrict-to-matches) (26 . 
ido-undo-merge-work-directory) (20 . ido-toggle-regexp) (67108908 . 
ido-prev-match) (67108910 . ido-next-match) (19 . ido-next-match) (18 . 
ido-prev-match) (16 . ido-toggle-prefix) (13 . ido-exit-minibuffer) (10 . 
ido-select-text) (32 . ido-complete-space) (9 . ido-complete) (5 . 
ido-edit-input) (3 . ido-toggle-case) (1 . ido-toggle-ignore) keymap (menu-bar 
keymap (minibuf "Minibuf" keymap (previous menu-item "Previous History Item" 
previous-history-element :help "Put previous minibuffer history element in the 
min...") (next menu-item "Next History Item" next-history-element :help "Put 
next minibuffer history element in the minibuf...") (isearch-backward m
 enu-item "Isearch History Backward" isearch-backward :help "Incrementally 
search minibuffer history backward") (isearch-forward menu-item "Isearch 
History Forward" isearch-forward :help "Incrementally search minibuffer history 
forward") (return menu-item "Enter" exit-minibuffer :key-sequence "\15" :help 
"Terminate input and exit minibuffer") (quit menu-item "Quit" 
abort-recursive-edit :help "Abort input and exit minibuffer") "Minibuf")) (10 . 
exit-minibuffer) (13 . exit-minibuffer) (7 . abort-recursive-edit) (C-tab . 
file-cache-minibuffer-complete) (9 . self-insert-command) (XF86Back . 
previous-history-element) (up . previous-line-or-history-element) (prior . 
previous-history-element) (XF86Forward . next-history-element) (down . 
next-line-or-history-element) (next . next-history-element) (27 keymap (60 . 
minibuffer-beginning-of-buffer) (114 . previous-matching-history-element) (115 
. next-matching-history-element) (112 . previous-history-element) (110 . 
next-history-element))) nil n
 il)
;;;   ido-read-internal(list "CHOOSE:  " nil nil confirm nil)
;;;   ido-completing-read("CHOOSE:  " (("pine" . "cones") ("oak" . "acorns") 
("maple" . "seeds")) nil confirm)
;;;   (let* ((alist '(("pine" . "cones") ("oak" . "acorns") ("maple" . 
"seeds"))) (choice (ido-completing-read "CHOOSE:  " alist nil 'confirm))) (cdr 
(assoc choice alist)))
;;;   (progn (let* ((alist '(("pine" . "cones") ("oak" . "acorns") ("maple" . 
"seeds"))) (choice (ido-completing-read "CHOOSE:  " alist nil 'confirm))) (cdr 
(assoc choice alist))))
;;;   eval((progn (let* ((alist '(("pine" . "cones") ("oak" . "acorns") 
("maple" . "seeds"))) (choice (ido-completing-read "CHOOSE:  " alist nil 
'confirm))) (cdr (assoc choice alist)))) t)
;;;   elisp--eval-last-sexp(nil)
;;;   eval-last-sexp(nil)
;;;   funcall-interactively(eval-last-sexp nil)
;;;   call-interactively(eval-last-sexp nil nil)
;;;   command-execute(eval-last-sexp)

Here is a draft proof concept that adds limited support for an alist collection 
using ido.  This is not intended to be a plug-in solution, but is rather 
intended to give the Emacs team some ideas regarding possible solutions.

(setq completions-format nil)

(defun ido-file-lessp (a b)
  ;; Simple compare two file names.
  (string-lessp (ido-no-final-slash (if (listp a) (car a) a))
                (ido-no-final-slash (if (listp b) (car b) b))))

(defun completion--insert-strings (strings)
  "Insert a list of STRINGS into the current buffer.
Uses columns to keep the listing readable but compact.
It also eliminates runs of equal strings."
  (when (consp strings)
    (let* ((length (apply 'max (mapcar (lambda (s)
                                         (if (consp s)
                                            (+ (string-width (car s))
                                               (if (listp (cdr s))
                                                 ;;; Add 3:  " " "[" "]"
                                                 (+ 3 (string-width (cadr s)))
                                                 ;;; Add 3:  " " "[" "]"
                                                 (+ 3 (string-width 
(replace-regexp-in-string "\n" "\\\\n" (cdr s))))))
                                            (string-width s)))
                                       strings)))
           (window (get-buffer-window (current-buffer) 0))
           (wwidth (if window (1- (window-width window)) 79))
           (columns (min
               ;; At least 2 columns; at least 2 spaces between columns.
               (max 2 (/ wwidth (+ 2 length)))
               ;; Don't allocate more columns than we can fill.
               ;; Windows can't show less than 3 lines anyway.
               (max 1 (/ (length strings) 2))))
           (colwidth (/ wwidth columns))
           (column 0)
           (rows (/ (length strings) columns))
           (row 0)
           (first t)
           (laststring nil))
      ;; The insertion should be "sensible" no matter what choices were made
      ;; for the parameters above.
      (dolist (str strings)
        (unless (equal laststring str) ; Remove (consecutive) duplicates.
          (setq laststring str)
          ;; FIXME: `string-width' doesn't pay attention to `display' 
properties.
          (let ((length (if (consp str)
                          (+ (string-width (car str))
                             (if (listp (cdr str))
                               ;;; Add 3:  " " "[" "]"
                               (+ 3 (string-width (cadr str)))
                               ;;; Add 3:  " ", "[", "]"
                               (+ 3 (string-width (replace-regexp-in-string 
"\n" "\\\\n" (cdr str))))))
                          (string-width str))))
            (cond ((eq completions-format 'vertical)
                     ;; Vertical format
                     (when (> row rows)
                       (forward-line (- -1 rows))
                       (setq row 0 column (+ column colwidth)))
                     (when (> column 0)
                       (end-of-line)
                       (while (> (current-column) column)
                         (if (eobp)
                             (insert "\n")
                           (forward-line 1)
                           (end-of-line)))
                       (insert " \t")
                       (set-text-properties (1- (point)) (point) `(display 
(space :align-to ,column)))))
                  ((eq completions-format 'horizontal)
                     ;; Horizontal format
                     (unless first
                       (if (< wwidth (+ (max colwidth length) column))
                         ;; No space for `str' at point, move to next line.
                         (progn (insert "\n")
                                (setq column 0))
                         (insert " \t")
                         ;; Leave the space unpropertized so that in the case 
we're
                         ;; already past the goal column, there is still a 
space displayed.
                         ;; We can't just set tab-width, because 
completion-setup-function will kill all local variables :-(
                         (set-text-properties (1- (point)) (point) `(display 
(space :align-to ,column))))))
                  (t
                     (when (> row 0)
                       (insert "\n"))))
            (setq first nil)
            (if (not (consp str))
              (add-text-properties (point) (progn (insert str)
                                                  (point))
                                   (list 'mouse-face 'highlight
                                         'the-completion-text-property str
                                         'face 'completions-choices-face))
              (add-text-properties (point) (progn (insert (car str)) (point))
                                   (list 'mouse-face 'highlight
                                         'the-completion-text-property (car str)
                                         'face 'completions-choices-face))
              (let ((beg (point))
                    (end (progn (if (listp (cdr str))
                                  (insert " [" (replace-regexp-in-string "\n" 
"\\\\n" (cadr str)) "]")
                                  (insert " [" (replace-regexp-in-string "\n" 
"\\\\n" (cdr str)) "]"))
                                (point))))
                (add-text-properties beg end (list 'mouse-face nil
                                                   
'the-completion-text-property (if (listp str)
                                                                                
   (car str)
                                                                                
   str)))
                (font-lock-prepend-text-property beg end 'face 
'completions-annotations-face)))
            (cond
              ((eq completions-format 'vertical)
                 ;; Vertical format
                 ;; (if (> column 0)
                 ;;   (forward-line)
                 ;;   (insert "\n"))
                 (insert-char ?\n 2)
                 (setq row (1+ row)))
              ((eq completions-format 'horizontal)
                 ;; Horizontal format
                 ;; Next column to align to.
                 ;; Round up to a whole number of columns.
                 (setq column (+ column (* colwidth (ceiling length 
colwidth)))))
              (t
                 (setq row (1+ row))))))))))

(defun choose-completion (&optional event)
  "Choose the completion at point.
If EVENT, use EVENT's position to determine the starting position."
  (interactive (list last-nonmenu-event))
  ;; In case this is run via the mouse, give temporary modes such as
  ;; isearch a chance to turn off.
  (run-hooks 'mouse-leave-buffer-hook)
  (with-current-buffer (window-buffer (posn-window (event-start event)))
    (let ((buffer completion-reference-buffer)
          (base-size completion-base-size)
          (base-position completion-base-position)
          (insert-function completion-list-insert-choice-function)
          (choice
            (save-excursion
              (goto-char (posn-point (event-start event)))
              (get-text-property (point) 'the-completion-text-property))))
      (unless (buffer-live-p buffer)
        (error "Destination buffer is dead"))
      (when (null choice)
        (let ((debug-on-quit nil))
          (signal 'quit '("choose-completion:  Please try again!"))))
      (quit-window nil (posn-window (event-start event)))
      (with-current-buffer buffer
        (choose-completion-string
         choice buffer
         (or base-position
             (when base-size
               ;; Someone's using old completion code that doesn't know
               ;; about base-position yet.
               (list (+ base-size (field-beginning))))
             ;; If all else fails, just guess.
             (list (choose-completion-guess-base-position choice)))
         insert-function)))))