unofficial mirror of emacs-devel@gnu.org 
 help / color / mirror / code / Atom feed
blob 11ac929efcfafb88655317d0ee58896fa3691c99 20445 bytes (raw)
name: lisp/completion-preview.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
 
;;; completion-preview.el --- Preview completion with inline overlay  -*- lexical-binding: t; -*-

;; Copyright (C) 2023-2024 Free Software Foundation, Inc.

;; Author: Eshel Yaron <me@eshelyaron.com>
;; Maintainer: Eshel Yaron <me@eshelyaron.com>
;; Keywords: abbrev convenience

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This library provides the Completion Preview mode.  This minor mode
;; displays a completion suggestion for the symbol at point in an
;; overlay after point.  Check out the customization group
;; `completion-preview' for user options that you may want to tweak.
;;
;; To enable Completion Preview mode, use `completion-preview-mode'.
;; To accept the completion suggestion, press TAB.  If you want to
;; ignore a completion suggestion, just go on editing or moving around
;; the buffer.  Completion Preview mode continues to update the
;; suggestion as you type according to the text around point.
;;
;; The commands `completion-preview-next-candidate' and
;; `completion-preview-prev-candidate' allow you to cycle the
;; completion candidate that the preview suggests.  These commands
;; don't have a default keybinding, but you can bind them, for
;; example, to M-n and M-p in `completion-preview-active-mode-map' to
;; have them handy whenever the preview is visible.
;;
;; If you set the user option `completion-preview-exact-match-only' to
;; non-nil, Completion Preview mode only suggests a completion
;; candidate when its the only possible completion for the (partial)
;; symbol at point.  The user option `completion-preview-commands'
;; says which commands should trigger the completion preview.  The
;; user option `completion-preview-minimum-symbol-length' specifies a
;; minimum number of consecutive characters with word or symbol syntax
;; that should appear around point for Emacs to suggest a completion.
;; By default, this option is set to 3, so Emacs suggests a completion
;; if you type "foo", but typing just "fo" doesn't show the preview.

;;; Code:

(require 'mwheel)

(defgroup completion-preview nil
  "In-buffer completion preview."
  :group 'completion)

(defcustom completion-preview-exact-match-only nil
  "Show completion preview only when there is an exact or common prefix match.

  If this option is t, Completion Preview mode only shows the preview when
there is exactly one completion candidate that matches the symbol at
point.
  If the option is `common', only shows the preview if there is a common
prefix in all the candidates and it is longer than the current input.
  Otherwise, if this option is nil, when there are multiple matching
candidates the preview shows the first candidate, and you can cycle
between the candidates with
\\[completion-preview-next-candidate] and
\\[completion-preview-prev-candidate]."
  :type '(choice (const :tag "Yes" t)
                 (const :tag "No" nil)
                 (const :tag "Common" common))
  :version "30.1")

(defcustom completion-preview-commands '(self-insert-command
                                         insert-char
                                         delete-backward-char
                                         backward-delete-char-untabify
                                         analyze-text-conversion)
  "List of commands that should trigger completion preview."
  :type '(repeat (function :tag "Command" :value self-insert-command))
  :version "30.1")

(defcustom completion-preview-minimum-symbol-length 3
  "Minimum length of the symbol at point for showing completion preview."
  :type 'natnum
  :version "30.1")

(defcustom completion-preview-message-format
  "Completion suggestion %i out of %n"
  "Message to show after cycling the completion preview suggestion.

If the value is a string, `completion-preview-next-candidate' and
`completion-preview-prev-candidate' display this string in the
echo area, after substituting \"%i\" with the 1-based index of
the completion suggestion that the preview is showing, and \"%n\"
with the total number of available completion suggestions for the
text around point.

If this option is nil, these commands do not display any message."
  :type '(choice (string :tag "Message format")
                 (const :tag "No message" nil))
  :version "30.1")

(defvar completion-preview-sort-function #'minibuffer--sort-by-length-alpha
  "Sort function to use for choosing a completion candidate to preview.")

(defface completion-preview
  '((t :inherit shadow))
  "Face for completion preview overlay."
  :version "30.1")

(defface completion-preview-exact
  '((((supports :underline t))
     :underline t :inherit completion-preview)
    (((supports :weight bold))
     :weight bold :inherit completion-preview)
    (t :background "gray"))
  "Face for exact completion preview overlay."
  :version "30.1")

(defface completion-preview-highlight
  '((t :inherit highlight))
  "Face for highlighting the completion preview when the mouse is over it."
  :version "30.1")

(defvar-keymap completion-preview-active-mode-map
  :doc "Keymap for Completion Preview Active mode."
  "C-i" #'completion-preview-insert
  ;; "M-n" #'completion-preview-next-candidate
  ;; "M-p" #'completion-preview-prev-candidate
  )

(defvar-keymap completion-preview--mouse-map
  :doc "Keymap for mouse clicks on the completion preview."
  "<down-mouse-1>" #'completion-preview-insert
  "C-<down-mouse-1>" #'completion-at-point
  "<down-mouse-2>" #'completion-at-point
  ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events
  ;; and vice versa!!
  "<wheel-up>"     #'completion-preview-prev-candidate
  "<wheel-down>"   #'completion-preview-next-candidate
  (key-description (vector mouse-wheel-up-event))
  #'completion-preview-next-candidate
  (key-description (vector mouse-wheel-down-event))
  #'completion-preview-prev-candidate)

(defvar-local completion-preview--overlay nil)

(defvar completion-preview--internal-commands
  '(completion-preview-next-candidate
    completion-preview-prev-candidate
    ;; Don't dismiss or update the preview when the user scrolls.
    mwheel-scroll)
  "List of commands that manipulate the completion preview.

Completion Preview mode avoids updating the preview after these commands.")

(defsubst completion-preview--internal-command-p ()
  "Return non-nil if `this-command' manipulates the completion preview."
  (memq this-command completion-preview--internal-commands))

(defsubst completion-preview-require-certain-commands ()
  "Check if `this-command' is one of `completion-preview-commands'."
  (or (completion-preview--internal-command-p)
      (memq this-command completion-preview-commands)))

(defun completion-preview-require-minimum-symbol-length ()
  "Check if the length of symbol at point is at least above a certain threshold.
`completion-preview-minimum-symbol-length' determines that threshold."
  (let ((bounds (bounds-of-thing-at-point 'symbol)))
    (and bounds (<= completion-preview-minimum-symbol-length
                    (- (cdr bounds) (car bounds))))))

(defun completion-preview-hide ()
  "Hide the completion preview."
  (when completion-preview--overlay
    (delete-overlay completion-preview--overlay)
    (setq completion-preview--overlay nil)))

(defun completion-preview--make-overlay (pos string)
  "Make preview overlay showing STRING at POS, or move existing preview there."
  (if completion-preview--overlay
      (move-overlay completion-preview--overlay pos pos)
    (setq completion-preview--overlay (make-overlay pos pos))
    (overlay-put completion-preview--overlay 'window (selected-window)))
  (let ((previous (overlay-get completion-preview--overlay 'after-string)))
    (unless (and previous (string= previous string)
                 (eq (get-text-property 0 'face previous)
                     (get-text-property 0 'face string)))
      (add-text-properties 0 1 '(cursor 1) string)
      (overlay-put completion-preview--overlay 'after-string string))
    completion-preview--overlay))

(defsubst completion-preview--get (prop)
  "Return property PROP of the completion preview overlay."
  (overlay-get completion-preview--overlay prop))

(defun completion-preview--window-selection-change (window)
  "Hide completion preview in WINDOW after switching to another window.
Completion Preview mode adds this function to
`window-selection-change-functions', which see."
  (unless (or (eq window (selected-window))
              (eq window (minibuffer-selected-window)))
    (with-current-buffer (window-buffer window)
      (completion-preview-active-mode -1))))

(define-minor-mode completion-preview-active-mode
  "Mode for when the completion preview is shown."
  :interactive nil
  (if completion-preview-active-mode
      (add-hook 'window-selection-change-functions
                #'completion-preview--window-selection-change nil t)
    (remove-hook 'window-selection-change-functions
                 #'completion-preview--window-selection-change t)
    (completion-preview-hide)))

(defun completion-preview--try-table (table beg end props)
  "Check TABLE for a completion matching the text between BEG and END.

PROPS is a property list with additional information about TABLE.
See `completion-at-point-functions' for more details.

If TABLE contains a matching completion, return a list
\(PREVIEW BEG END ALL BASE EXIT-FN) where PREVIEW is the text to
show in the completion preview, ALL is the list of all matching
completion candidates, BASE is a common prefix that TABLE elided
from the start of each candidate, and EXIT-FN is either a
function to call after inserting PREVIEW or nil.  If TABLE does
not contain matching completions, or if there are multiple
matching completions and `completion-preview-exact-match-only' is
non-nil, return nil instead."
  (let* ((pred (plist-get props :predicate))
         (exit-fn (plist-get props :exit-function))
         (string (buffer-substring beg end))
         (md (completion-metadata string table pred))
         (sort-fn (or (completion-metadata-get md 'cycle-sort-function)
                      (completion-metadata-get md 'display-sort-function)
                      completion-preview-sort-function))
         (all (let ((completion-lazy-hilit t)
                    (completion-styles (pcase completion-preview-exact-match-only
                                         ('common '(basic))
                                         (_ completion-styles))))
                (completion-all-completions string table pred
                                            (- (point) beg) md)))
         (last (last all))
         (base (or (cdr last) 0))
         (prefix (substring string base)))
    (when last
      (setcdr last nil)
      (when-let ((sorted (cond
                          ((not completion-preview-exact-match-only)
                           (funcall sort-fn
                                    (delete prefix (all-completions prefix all))))
                          ((eq completion-preview-exact-match-only t)
                           (when-let ((cands (delete prefix (all-completions prefix all))))
                             (unless (cdr cands) cands)))
                          ((eq completion-preview-exact-match-only 'common)
			   (when-let ((cand (try-completion prefix all)))
                             (when (and (stringp cand)
                                        (> (length cand) (length prefix)))
                               (list cand))))
                          )))

        (list (propertize (substring (car sorted) (length prefix))
                          'face (if (cdr sorted)
                                    'completion-preview
                                  'completion-preview-exact)
                          'mouse-face 'completion-preview-highlight
                          'keymap completion-preview--mouse-map)
              (+ beg base) end sorted
              (substring string 0 base) exit-fn)))))

(defun completion-preview--capf-wrapper (capf)
  "Translate return value of CAPF to properties for completion preview overlay."
  (let ((res (ignore-errors (funcall capf))))
    (and (consp res)
         (not (functionp res))
         (seq-let (beg end table &rest plist) res
           (or (completion-preview--try-table table beg end plist)
               (unless (eq 'no (plist-get plist :exclusive))
                 ;; Return non-nil to exclude other capfs.
                 '(nil)))))))

(defun completion-preview--update ()
  "Update completion preview."
  (seq-let (preview beg end all base exit-fn)
      (run-hook-wrapped
       'completion-at-point-functions
       #'completion-preview--capf-wrapper)
    (when preview
      (let ((ov (completion-preview--make-overlay end preview)))
        (overlay-put ov 'completion-preview-beg beg)
        (overlay-put ov 'completion-preview-end end)
        (overlay-put ov 'completion-preview-index 0)
        (overlay-put ov 'completion-preview-cands all)
        (overlay-put ov 'completion-preview-base base)
        (overlay-put ov 'completion-preview-exit-fn exit-fn)
        (completion-preview-active-mode)))))

(defun completion-preview--show ()
  "Show a new completion preview.

Call `completion-at-point-functions' in order to obtain and
display a completion candidate for the text around point.

If the preview is already shown, first check whether the
suggested candidate remains a valid completion for the text at
point.  If so, update the preview according the new text at
point, otherwise hide it."
  (when completion-preview-active-mode
    ;; We were already showing a preview before this command, so we
    ;; check if the text before point is still a prefix of the
    ;; candidate that the preview suggested, and if so we first update
    ;; existing preview according to the changes made by this command,
    ;; and only then try to get a new candidate.  This ensures that we
    ;; never display a stale preview and that the preview doesn't
    ;; flicker, even with slow completion backends.
    (let* ((beg (completion-preview--get 'completion-preview-beg))
           (end (max (point) (overlay-start completion-preview--overlay)))
           (cands (completion-preview--get 'completion-preview-cands))
           (index (completion-preview--get 'completion-preview-index))
           (cand (nth index cands))
           (after (completion-preview--get 'after-string))
           (face (get-text-property 0 'face after)))
      (if (and (<= beg (point) end (1- (+ beg (length cand))))
               (string-prefix-p (buffer-substring beg end) cand))
          ;; The previous preview is still applicable, update it.
          (overlay-put (completion-preview--make-overlay
                        end (propertize (substring cand (- end beg))
                                        'face face
                                        'mouse-face 'completion-preview-highlight
                                        'keymap completion-preview--mouse-map))
                       'completion-preview-end end)
        ;; The previous preview is no longer applicable, hide it.
        (completion-preview-active-mode -1))))
  ;; Run `completion-at-point-functions' to get a new candidate.
  (while-no-input (completion-preview--update)))

(defun completion-preview--post-command ()
  "Create, update or delete completion preview post last command."
  (if (and (completion-preview-require-certain-commands)
           (completion-preview-require-minimum-symbol-length))
      ;; We should show the preview.
      (or
       ;; If we're called after a command that itself updates the
       ;; preview, don't do anything.
       (completion-preview--internal-command-p)
       ;; Otherwise, show the preview.
       (completion-preview--show))
    (completion-preview-active-mode -1)))

(defun completion-preview-insert ()
  "Insert the completion candidate that the preview is showing."
  (interactive)
  (if completion-preview-active-mode
      (let* ((pre (completion-preview--get 'completion-preview-base))
             (end (completion-preview--get 'completion-preview-end))
             (ind (completion-preview--get 'completion-preview-index))
             (all (completion-preview--get 'completion-preview-cands))
             (efn (completion-preview--get 'completion-preview-exit-fn))
             (aft (completion-preview--get 'after-string))
             (str (concat pre (nth ind all))))
        (completion-preview-active-mode -1)
        (goto-char end)
        (insert (substring-no-properties aft))
        (when (functionp efn) (funcall efn str 'finished)))
    (user-error "No current completion preview")))

(defun completion-preview-prev-candidate ()
  "Cycle the candidate that the preview is showing to the previous suggestion."
  (interactive)
  (completion-preview-next-candidate -1))

(defun completion-preview-next-candidate (direction)
  "Cycle the candidate that the preview is showing in direction DIRECTION.

DIRECTION should be either 1 which means cycle forward, or -1
which means cycle backward.  Interactively, DIRECTION is the
prefix argument and defaults to 1."
  (interactive "p")
  (when completion-preview-active-mode
    (let* ((beg (completion-preview--get 'completion-preview-beg))
           (end (completion-preview--get 'completion-preview-end))
           (all (completion-preview--get 'completion-preview-cands))
           (cur (completion-preview--get 'completion-preview-index))
           (len (length all))
           (new (mod (+ cur direction) len))
           (str (nth new all)))
      (while (or (<= (+ beg (length str)) end)
                 (not (string-prefix-p (buffer-substring beg end) str)))
        (setq new (mod (+ new direction) len) str (nth new all)))
      (let ((aft (propertize (substring str (- end beg))
                             'face (if (< 1 len)
                                       'completion-preview
                                     'completion-preview-exact)
                             'mouse-face 'completion-preview-highlight
                             'keymap completion-preview--mouse-map)))
        (add-text-properties 0 1 '(cursor 1) aft)
        (overlay-put completion-preview--overlay 'completion-preview-index new)
        (overlay-put completion-preview--overlay 'after-string aft))
      (when completion-preview-message-format
        (message (format-spec completion-preview-message-format
                              `((?i . ,(1+ new)) (?n . ,len))))))))

(defun completion-preview--active-p (_symbol buffer)
  "Check if the completion preview is currently shown in BUFFER."
  (buffer-local-value 'completion-preview-active-mode buffer))

(dolist (cmd '(completion-preview-insert
               completion-preview-prev-candidate
               completion-preview-next-candidate))
  (put cmd 'completion-predicate #'completion-preview--active-p))

;;;###autoload
(define-minor-mode completion-preview-mode
  "Show in-buffer completion suggestions in a preview as you type.

This mode automatically shows and updates the completion preview
according to the text around point.
\\<completion-preview-active-mode-map>\
When the preview is visible, \\[completion-preview-insert]
accepts the completion suggestion,
\\[completion-preview-next-candidate] cycles forward to the next
completion suggestion, and \\[completion-preview-prev-candidate]
cycles backward."
  :lighter " CP"
  (if completion-preview-mode
      (add-hook 'post-command-hook #'completion-preview--post-command nil t)
    (remove-hook 'post-command-hook #'completion-preview--post-command t)
    (completion-preview-active-mode -1)))

;;;###autoload
(define-globalized-minor-mode global-completion-preview-mode
  completion-preview-mode completion-preview-mode
  :predicate '((not minibuffer-mode special-mode) t))

(provide 'completion-preview)
;;; completion-preview.el ends here

debug log:

solving 11ac929efcf ...
found 11ac929efcf in https://yhetil.org/emacs-devel/njlevizac6zitj5fulduqcgtfwhac5vmcsz2we562fym7z5u6i@su5oafrms4r7/
found a86c1ba1cc9 in https://git.savannah.gnu.org/cgit/emacs.git
preparing index
index prepared:
100644 a86c1ba1cc9c749005fe474e95eee66bf39d779e	lisp/completion-preview.el

applying [1/1] https://yhetil.org/emacs-devel/njlevizac6zitj5fulduqcgtfwhac5vmcsz2we562fym7z5u6i@su5oafrms4r7/
diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index a86c1ba1cc9..11ac929efcf 100644

Checking patch lisp/completion-preview.el...
Applied patch lisp/completion-preview.el cleanly.

index at:
100644 11ac929efcfafb88655317d0ee58896fa3691c99	lisp/completion-preview.el

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).