Improve icomplete-vertical-mode and fido-vertical-mode

This mode is intended to be used with Icomplete ('M-x icomplete-mode')
or Fido ('M-x fido-mode'), to display the list of completions
candidates vertically instead of horizontally.  When used with
Icomplete, completions are rotated and selection kept at the top.
When used with Fido, completions scroll like a typical dropdown
widget.

If the dropdown behaviour is desired for Icomplete (instead of
rotation), icomplete-scroll can be adjusted separately by the user.

* etc/NEWS (icomplete-vertical-mode): Reword.

* lisp/icomplete.el (simple): Require it.
(icomplete-selected-match): New face.
(icomplete-scroll): New user-visible var.
(icomplete-forward-completions): Rework.
(icomplete-backward-completions): Rework.
(icomplete--fido-mode-setup): Prefer icomplete-scroll according to
icomplete-vertical mode.
(icomplete-minibuffer-setup): Initialize icomplete--scrolled-completions.
(fido-vertical-mode): An alias for icomplete-vertical-mode.
(icomplete-exhibit): Init icomplete--scrolled-past.  Adjust overlay.
(icomplete--render-vertical): New helper.
(icomplete--sorted-completions): If cache is stale, also
invalidate icomplete--scrolled-past.
(icomplete-completions): Rework.  Mostly reformat.

* lisp/simple.el (max-mini-window-lines): New helper.
(display-message-or-buffer): Use it.

3 files changed, 257 insertions, 136 deletions

diff --git a/etc/NEWS b/etc/NEWS
index fe8789c60b3..914e6890321 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -534,9 +534,13 @@ indentation is done using SMIE or with the old ad-hoc code.
 ** Icomplete
 
 +++
-*** New minor mode 'icomplete-vertical-mode'.
-This mode is intended to be used with Icomplete or Fido, to display the
-list of completions candidates vertically instead of horizontally.
+*** New minor mode 'icomplete-vertical-mode', alias 'fido-vertical-mode'
+This mode is intended to be used with Icomplete ('M-x icomplete-mode')
+or Fido ('M-x fido-mode'), to display the list of completions
+candidates vertically instead of horizontally.  When used with
+Icomplete, completions are rotated and selection kept at the top.
+When used with Fido, completions scroll like a typical dropdown
+widget.
 
 ---
 ** Specific warnings can now be disabled from the warning buffer.
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index 91bbb600136..f813a1776e8 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -50,6 +50,8 @@
 ;;; Code:
 
 (require 'rfn-eshadow) ; rfn-eshadow-overlay
+(require 'simple) ; max-mini-window-lines
+(require 'cl-lib)
 
 (defgroup icomplete nil
   "Show completions dynamically in minibuffer."
@@ -99,6 +101,10 @@ Otherwise this should be a list of the completion tables (e.g.,
   "Face used by Icomplete for highlighting first match."
   :version "24.4")
 
+(defface icomplete-selected-match '((t :inherit highlight))
+  "Face used by `icomplete-vertical-mode' for the selected candidate."
+  :version "24.4")
+
 ;;;_* User Customization variables
 (defcustom icomplete-prospects-height 2
   ;; We used to compute how many lines 100 characters would take in
@@ -215,6 +221,29 @@ the default otherwise."
   ;; We're not at all interested in cycling here (bug#34077).
   (minibuffer-force-complete nil nil 'dont-cycle))
 
+;; Apropos `icomplete-scroll', we implement "scrolling icomplete"
+;; within classic icomplete, which is "rotating", by contrast.
+;;
+;; The two variables supporing this are
+;; `icomplete--scrolled-completions' and `icomplete--scrolled-past'.
+;; They come into play when:
+;;
+;; - The user invokes commands `icomplete-forward-completions' and
+;;   `icomplete-backward-completions', thus "manually" scrolling to a
+;;   given position;
+;;
+;; - The user re-filters a selection that had already been manually
+;;   scrolled.  The system attempts to keep the previous selection
+;;   stable in the face of the new filtering.  This is mostly done in
+;;   `icomplete--render-vertical'.
+;;
+(defvar icomplete-scroll nil
+  "If non-nil, scroll candidates list instead of rotating it.")
+(defvar icomplete--scrolled-completions nil
+  "If non-nil, tail of completions list manually scrolled to.")
+(defvar icomplete--scrolled-past nil
+  "If non-nil, reverse tail of completions scrolled past.")
+
 (defun icomplete-forward-completions ()
   "Step forward completions by one entry.
 Second entry becomes the first and can be selected with
@@ -223,10 +252,14 @@ Second entry becomes the first and can be selected with
   (let* ((beg (icomplete--field-beg))
          (end (icomplete--field-end))
          (comps (completion-all-sorted-completions beg end))
-         (last (last comps)))
-    (when comps
-      (setcdr last (cons (car comps) (cdr last)))
-      (completion--cache-all-sorted-completions beg end (cdr comps)))))
+         (last (last comps)))
+    (when (consp (cdr comps))
+      (cond (icomplete-scroll
+             (push (pop comps) icomplete--scrolled-past)
+             (setq icomplete--scrolled-completions comps))
+            (t
+             (setcdr (last comps) (cons (pop comps) (cdr last)))))
+      (completion--cache-all-sorted-completions beg end comps))))
 
 (defun icomplete-backward-completions ()
   "Step backward completions by one entry.
@@ -236,12 +269,16 @@ Last entry becomes the first and can be selected with
   (let* ((beg (icomplete--field-beg))
          (end (icomplete--field-end))
          (comps (completion-all-sorted-completions beg end))
-         (last-but-one (last comps 2))
-         (last (cdr last-but-one)))
-    (when (consp last)                ; At least two elements in comps
-      (setcdr last-but-one (cdr last))
-      (push (car last) comps)
-      (completion--cache-all-sorted-completions beg end comps))))
+         last-but-one)
+    (cond ((and icomplete-scroll icomplete--scrolled-past)
+           (push (pop icomplete--scrolled-past) comps)
+           (setq icomplete--scrolled-completions comps))
+          ((and (not icomplete-scroll)
+                (consp (cdr (setq last-but-one (last comps 2)))))
+           ;; At least two elements in comps
+           (push (car (cdr last-but-one)) comps)
+           (setcdr last-but-one (cdr (cdr last-but-one)))))
+    (completion--cache-all-sorted-completions beg end comps)))
 
 ;;; Helpers for `fido-mode' (or `ido-mode' emulation)
 ;;;
@@ -351,6 +388,7 @@ if that doesn't produce a completion match."
     (setq-local icomplete-tidy-shadowed-file-names t
                 icomplete-show-matches-on-no-input t
                 icomplete-hide-common-prefix nil
+                icomplete-scroll (not (null icomplete-vertical-mode))
                 completion-styles '(flex)
                 completion-flex-nospace nil
                 completion-category-defaults nil
@@ -449,6 +487,7 @@ Usually run by inclusion in `minibuffer-setup-hook'."
   (when (and icomplete-mode (icomplete-simple-completing-p))
     (setq-local icomplete--initial-input (icomplete--field-string))
     (setq-local completion-show-inline-help nil)
+    (setq icomplete--scrolled-completions nil)
     (use-local-map (make-composed-keymap icomplete-minibuffer-map
                                          (current-local-map)))
     (add-hook 'pre-command-hook  #'icomplete-pre-command-hook  nil t)
@@ -483,6 +522,7 @@ Usually run by inclusion in `minibuffer-setup-hook'."
 (defun icomplete--sorted-completions ()
   (or completion-all-sorted-completions
       (cl-loop
+       initially (setq icomplete--scrolled-past nil) ; Invalidate scrolled state
        with beg = (icomplete--field-beg)
        with end = (icomplete--field-end)
        with all = (completion-all-sorted-completions beg end)
@@ -593,6 +633,8 @@ resized depends on `resize-mini-windows'."
     (add-hook 'icomplete-minibuffer-setup-hook
               #'icomplete--vertical-minibuffer-setup)))
 
+(defalias 'fido-vertical-mode 'icomplete-vertical-mode)
+
 
 
 
@@ -659,13 +701,85 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
                  deactivate-mark)
             ;; Do nothing if while-no-input was aborted.
             (when (stringp text)
-              (move-overlay icomplete-overlay (point) (point) (current-buffer))
+              (move-overlay icomplete-overlay (point-min) (point) (current-buffer))
               ;; The current C cursor code doesn't know to use the overlay's
               ;; marker's stickiness to figure out whether to place the cursor
               ;; before or after the string, so let's spoon-feed it the pos.
               (put-text-property 0 1 'cursor t text)
+              (overlay-put
+               icomplete-overlay 'before-string
+               (and icomplete-scroll
+                    (let ((past (length icomplete--scrolled-past)))
+                      (format
+                       "%s/%s "
+                       (1+ past)
+                       (+ past
+                          (safe-length completion-all-sorted-completions))))))
               (overlay-put icomplete-overlay 'after-string text))))))))
 
+(cl-defun icomplete--render-vertical (comps &aux scroll-above scroll-below)
+  ;; Welcome to loopapalooza!
+  ;;
+  ;; First, be mindful of `icomplete-scroll' and manual scrolls.  If
+  ;; `icomplete--scrolled-completions' and `icomplete--scrolled-past'
+  ;; are:
+  ;;
+  ;; - both nil, there is no manual scroll;
+  ;; - both non-nil, there is a healthy manual scroll the doesn't need
+  ;;   to be readjusted (user just moved around the minibuffer, for
+  ;;   example)l
+  ;; - non-nil and nil, respectively, a refiltering took place and we
+  ;;   need attempt to readjust them to the new filtered `comps'.
+  (when (and icomplete-scroll
+             icomplete--scrolled-completions
+             (null icomplete--scrolled-past))
+    (cl-loop with preds
+             for (comp . rest) on comps
+             when (equal comp (car icomplete--scrolled-completions))
+             do
+             (setq icomplete--scrolled-past preds
+                   comps (cons comp rest))
+             (completion--cache-all-sorted-completions
+              (icomplete--field-beg)
+              (icomplete--field-end)
+              comps)
+             and return nil
+             do (push comp preds)
+             finally (setq icomplete--scrolled-completions nil)))
+  ;; Then, in this pretty ugly loop, collect completions to display
+  ;; above and below the selected one, considering scrolling
+  ;; positions.
+  (cl-loop with preds = icomplete--scrolled-past
+           with succs = (cdr comps)
+           with max-lines = (1- (min
+                                 icomplete-prospects-height
+                                 (truncate (max-mini-window-lines) 1)))
+           with max-above = (- max-lines
+                               1
+                               (cl-loop for (_ . r) on comps
+                                        repeat (truncate max-lines 2)
+                                        while (listp r)
+                                        count 1))
+           repeat max-lines
+           for neighbour = nil
+           if (and preds (> max-above 0)) do
+           (push (setq neighbour (pop preds)) scroll-above)
+           (cl-decf max-above)
+           else if (consp succs) collect
+           (setq neighbour (pop succs)) into scroll-below-aux
+           while neighbour
+           finally (setq scroll-below scroll-below-aux))
+  ;; Now figure out spacing and layout
+  ;;
+  (let ((selected (substring (car comps))))
+    (add-face-text-property 0 (length selected)
+                            'icomplete-selected-match 'append selected)
+    (concat " " icomplete-separator
+            (mapconcat
+             #'identity
+             (nconc scroll-above (list selected) scroll-below)
+             icomplete-separator))))
+
 ;;;_ > icomplete-completions (name candidates predicate require-match)
 (defun icomplete-completions (name candidates predicate require-match)
   "Identify prospective candidates for minibuffer completion.
@@ -703,126 +817,126 @@ matches exist."
             predicate))
          (md (completion--field-metadata (icomplete--field-beg)))
          (comps (icomplete--sorted-completions))
-         (last (if (consp comps) (last comps)))
-         (base-size (cdr last))
          (open-bracket (if require-match "(" "["))
          (close-bracket (if require-match ")" "]")))
     ;; `concat'/`mapconcat' is the slow part.
     (if (not (consp comps))
         (progn ;;(debug (format "Candidates=%S field=%S" candidates name))
           (format " %sNo matches%s" open-bracket close-bracket))
-      (if last (setcdr last nil))
-      (let* ((most-try
-              (if (and base-size (> base-size 0))
+      (if icomplete-vertical-mode
+          (icomplete--render-vertical comps)
+        (let* ((last (if (consp comps) (last comps)))
+               ;; Save the "base size" encoded in `comps' then
+               ;; removing making `comps' a proper list.
+               (base-size (prog1 (cdr last)
+                            (if last (setcdr last nil))))
+               (most-try
+                (if (and base-size (> base-size 0))
+                    (completion-try-completion
+                     name candidates predicate (length name) md)
+                  ;; If the `comps' are 0-based, the result should be
+                  ;; the same with `comps'.
                   (completion-try-completion
-                   name candidates predicate (length name) md)
-                ;; If the `comps' are 0-based, the result should be
-                ;; the same with `comps'.
-                (completion-try-completion
-                 name comps nil (length name) md)))
-             (most (if (consp most-try) (car most-try)
-                     (if most-try (car comps) "")))
-             ;; Compare name and most, so we can determine if name is
-             ;; a prefix of most, or something else.
-             (compare (compare-strings name nil nil
-                                       most nil nil completion-ignore-case))
-             (ellipsis (if (char-displayable-p ?…) "…" "..."))
-             (determ (unless (or (eq t compare) (eq t most-try)
-                                 (= (setq compare (1- (abs compare)))
-                                    (length most)))
-                       (concat open-bracket
-                               (cond
-                                ((= compare (length name))
-                                 ;; Typical case: name is a prefix.
-                                 (substring most compare))
-                                ;; Don't bother truncating if it doesn't gain
-                                ;; us at least 2 columns.
-                                ((< compare (+ 2 (string-width ellipsis))) most)
-                                (t (concat ellipsis (substring most compare))))
-                               close-bracket)))
-             ;;"-prospects" - more than one candidate
-             (prospects-len (+ (string-width
-                                (or determ (concat open-bracket close-bracket)))
-                               (string-width icomplete-separator)
-                               (+ 2 (string-width ellipsis)) ;; take {…} into account
-                               (string-width (buffer-string))))
-             (prospects-max
-              ;; Max total length to use, including the minibuffer content.
-              (* (+ icomplete-prospects-height
-                    ;; If the minibuffer content already uses up more than
-                    ;; one line, increase the allowable space accordingly.
-                    (/ prospects-len (window-width)))
-                 (window-width)))
-             ;; Find the common prefix among `comps'.
-             ;; We can't use the optimization below because its assumptions
-             ;; aren't always true, e.g. when completion-cycling (bug#10850):
-             ;; (if (eq t (compare-strings (car comps) nil (length most)
-             ;;                          most nil nil completion-ignore-case))
-             ;;     ;; Common case.
-             ;;     (length most)
-             ;; Else, use try-completion.
-             (prefix (when icomplete-hide-common-prefix
-                       (try-completion "" comps)))
-             (prefix-len
-              (and (stringp prefix)
-                   ;; Only hide the prefix if the corresponding info
-                   ;; is already displayed via `most'.
-                   (string-prefix-p prefix most t)
-                   (length prefix))) ;;)
-             prospects comp limit)
-        (if (or (eq most-try t) (not (consp (cdr comps))))
-            (setq prospects nil)
-          (when (member name comps)
-            ;; NAME is complete but not unique.  This scenario poses
-            ;; following UI issues:
-            ;;
-            ;; - When `icomplete-hide-common-prefix' is non-nil, NAME
-            ;;   is stripped empty.  This would make the entry
-            ;;   inconspicuous.
-            ;;
-            ;; - Due to sorting of completions, NAME may not be the
-            ;;   first of the prospects and could be hidden deep in
-            ;;   the displayed string.
-            ;;
-            ;; - Because of `icomplete-prospects-height' , NAME may
-            ;;   not even be displayed to the user.
-            ;;
-            ;; To circumvent all the above problems, provide a visual
-            ;; cue to the user via an "empty string" in the try
-            ;; completion field.
-            (setq determ (concat open-bracket "" close-bracket)))
-          ;; Compute prospects for display.
-          (while (and comps (not limit))
-            (setq comp
-                  (if prefix-len (substring (car comps) prefix-len) (car comps))
-                  comps (cdr comps))
-            (setq prospects-len
-                  (+ (string-width comp)
-                     (string-width icomplete-separator)
-                     prospects-len))
-            (if (< prospects-len prospects-max)
-                (push comp prospects)
-              (setq limit t))))
-        (setq prospects (nreverse prospects))
-        ;; Decorate first of the prospects.
-        (when prospects
-          (let ((first (copy-sequence (pop prospects))))
-            (put-text-property 0 (length first)
-                               'face 'icomplete-first-match first)
-            (push first prospects)))
-        ;; Restore the base-size info, since completion-all-sorted-completions
-        ;; is cached.
-        (if last (setcdr last base-size))
-        (if prospects
-            (concat determ
-                    (if icomplete-vertical-mode " \n" "{")
-                    (mapconcat 'identity prospects (if icomplete-vertical-mode
-                                                       "\n"
-                                                       icomplete-separator))
-                    (unless icomplete-vertical-mode
-                      (concat (and limit (concat icomplete-separator ellipsis))
-                              "}")))
-          (concat determ " [Matched]"))))))
+                   name comps nil (length name) md)))
+               (most (if (consp most-try) (car most-try)
+                       (if most-try (car comps) "")))
+               ;; Compare name and most, so we can determine if name is
+               ;; a prefix of most, or something else.
+               (compare (compare-strings name nil nil
+                                         most nil nil completion-ignore-case))
+               (ellipsis (if (char-displayable-p ?…) "…" "..."))
+               (determ (unless (or (eq t compare) (eq t most-try)
+                                   (= (setq compare (1- (abs compare)))
+                                      (length most)))
+                         (concat open-bracket
+                                 (cond
+                                  ((= compare (length name))
+                                   ;; Typical case: name is a prefix.
+                                   (substring most compare))
+                                  ;; Don't bother truncating if it doesn't gain
+                                  ;; us at least 2 columns.
+                                  ((< compare (+ 2 (string-width ellipsis))) most)
+                                  (t (concat ellipsis (substring most compare))))
+                                 close-bracket)))
+               ;;"-prospects" - more than one candidate
+               (prospects-len (+ (string-width
+                                  (or determ (concat open-bracket close-bracket)))
+                                 (string-width icomplete-separator)
+                                 (+ 2 (string-width ellipsis)) ;; take {…} into account
+                                 (string-width (buffer-string))))
+               (prospects-max
+                ;; Max total length to use, including the minibuffer content.
+                (* (+ icomplete-prospects-height
+                      ;; If the minibuffer content already uses up more than
+                      ;; one line, increase the allowable space accordingly.
+                      (/ prospects-len (window-width)))
+                   (window-width)))
+               ;; Find the common prefix among `comps'.
+               ;; We can't use the optimization below because its assumptions
+               ;; aren't always true, e.g. when completion-cycling (bug#10850):
+               ;; (if (eq t (compare-strings (car comps) nil (length most)
+               ;;                        most nil nil completion-ignore-case))
+               ;;     ;; Common case.
+               ;;     (length most)
+               ;; Else, use try-completion.
+               (prefix (when icomplete-hide-common-prefix
+                         (try-completion "" comps)))
+               (prefix-len
+                (and (stringp prefix)
+                     ;; Only hide the prefix if the corresponding info
+                     ;; is already displayed via `most'.
+                     (string-prefix-p prefix most t)
+                     (length prefix))) ;;)
+               prospects comp limit)
+          (prog1
+              (if (or (eq most-try t) (and (not icomplete-scroll)
+                                           (not (consp (cdr comps)))))
+                  (concat determ " [Matched]")
+                (when (member name comps)
+                  ;; NAME is complete but not unique.  This scenario poses
+                  ;; following UI issues:
+                  ;;
+                  ;; - When `icomplete-hide-common-prefix' is non-nil, NAME
+                  ;;   is stripped empty.  This would make the entry
+                  ;;   inconspicuous.
+                  ;;
+                  ;; - Due to sorting of completions, NAME may not be the
+                  ;;   first of the prospects and could be hidden deep in
+                  ;;   the displayed string.
+                  ;;
+                  ;; - Because of `icomplete-prospects-height' , NAME may
+                  ;;   not even be displayed to the user.
+                  ;;
+                  ;; To circumvent all the above problems, provide a visual
+                  ;; cue to the user via an "empty string" in the try
+                  ;; completion field.
+                  (setq determ (concat open-bracket "" close-bracket)))
+                (while (and comps (not limit))
+                  (setq comp
+                        (if prefix-len (substring (car comps) prefix-len) (car comps))
+                        comps (cdr comps))
+                  (setq prospects-len
+                        (+ (string-width comp)
+                           (string-width icomplete-separator)
+                           prospects-len))
+                  (if (< prospects-len prospects-max)
+                      (push comp prospects)
+                    (setq limit t)))
+                (setq prospects (nreverse prospects))
+                ;; Decorate first of the prospects.
+                (when prospects
+                  (let ((first (copy-sequence (pop prospects))))
+                    (put-text-property 0 (length first)
+                                       'face 'icomplete-first-match first)
+                    (push first prospects)))
+                (concat determ
+                        "{"
+                        (mapconcat 'identity prospects icomplete-separator)
+                        (concat (and limit (concat icomplete-separator ellipsis))
+                                "}")))
+            ;; Restore the base-size info, since completion-all-sorted-completions
+            ;; is cached.
+            (if last (setcdr last base-size))))))))
 
 ;;; Iswitchb compatibility
 
diff --git a/lisp/simple.el b/lisp/simple.el
index cdd77f74c3e..6d216f74d91 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -4217,12 +4217,22 @@ impose the use of a shell (with its need to quote arguments)."
             (shell-command-on-region (point) (point) command
                                      output-buffer nil error-buffer)))))))
 
+(defun max-mini-window-lines (&optional frame)
+  "Compute maximum number of lines for echo area in FRAME.
+As defined by `max-mini-window-height'.  FRAME defaults to the
+selected frame.  Result may be a floating-point number,
+i.e. include a fractional number of lines."
+  (cond ((floatp max-mini-window-height) (* (frame-height frame)
+                                            max-mini-window-height))
+        ((integerp max-mini-window-height) max-mini-window-height)
+        (t 1)))
+
 (defun display-message-or-buffer (message &optional buffer-name action frame)
   "Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer.
 MESSAGE may be either a string or a buffer.
 
 A pop-up buffer is displayed using `display-buffer' if MESSAGE is too long
-for maximum height of the echo area, as defined by `max-mini-window-height'
+for maximum height of the echo area, as defined by `max-mini-window-lines'
 if `resize-mini-windows' is non-nil.
 
 Returns either the string shown in the echo area, or when a pop-up
@@ -4261,14 +4271,7 @@ and are used only if a pop-up buffer is displayed."
              (cond ((= lines 0))
                    ((and (or (<= lines 1)
                              (<= lines
-                                 (if resize-mini-windows
-                                     (cond ((floatp max-mini-window-height)
-                                            (* (frame-height)
-                                               max-mini-window-height))
-                                           ((integerp max-mini-window-height)
-                                            max-mini-window-height)
-                                           (t
-                                            1))
+                                 (if resize-mini-windows (max-mini-window-lines)
                                    1)))
                          ;; Don't use the echo area if the output buffer is
                          ;; already displayed in the selected frame.