]> code.delx.au - gnu-emacs-elpa/blob - packages/avy/avy.el
Fix some quoting problems in doc strings
[gnu-emacs-elpa] / packages / avy / avy.el
1 ;;; avy.el --- tree-based completion -*- lexical-binding: t -*-
2
3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
4
5 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
6 ;; URL: https://github.com/abo-abo/avy
7 ;; Version: 0.4.0
8 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
9 ;; Keywords: point, location
10
11 ;; This file is part of GNU Emacs.
12
13 ;; This file is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 3, or (at your option)
16 ;; any later version.
17
18 ;; This program is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
22
23 ;; For a full copy of the GNU General Public License
24 ;; see <http://www.gnu.org/licenses/>.
25
26 ;;; Commentary:
27 ;;
28 ;; This package provides a generic completion method based on building
29 ;; a balanced decision tree with each candidate being a leaf. To
30 ;; traverse the tree from the root to a desired leaf, typically a
31 ;; sequence of `read-key' can be used.
32 ;;
33 ;; In order for `read-key' to make sense, the tree needs to be
34 ;; visualized appropriately, with a character at each branch node. So
35 ;; this completion method works only for things that you can see on
36 ;; your screen, all at once:
37 ;;
38 ;; * character positions
39 ;; * word or subword start positions
40 ;; * line beginning positions
41 ;; * link positions
42 ;; * window positions
43 ;;
44 ;; If you're familiar with the popular `ace-jump-mode' package, this
45 ;; package does all that and more, without the implementation
46 ;; headache.
47
48 ;;; Code:
49 (require 'cl-lib)
50 (require 'ring)
51
52 ;;* Customization
53 (defgroup avy nil
54 "Jump to things tree-style."
55 :group 'convenience
56 :prefix "avy-")
57
58 (defcustom avy-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)
59 "Default keys for jumping.
60 Any key is either a character representing a self-inserting
61 key (letters, digits, punctuation, etc.) or a symbol denoting a
62 non-printing key like an arrow key (left, right, up, down). For
63 non-printing keys, a corresponding entry in
64 `avy-key-to-char-alist' must exist in order to visualize the key
65 in the avy overlays."
66 :type '(repeat :tag "Keys" (choice (character :tag "char")
67 (symbol :tag "non-printing key"))))
68
69 (defcustom avy-keys-alist nil
70 "Alist of avy-jump commands to `avy-keys' overriding the default `avy-keys'."
71 :type '(alist
72 :key-type (choice :tag "Command"
73 (const avy-goto-char)
74 (const avy-goto-char-2)
75 (const avy-isearch)
76 (const avy-goto-line)
77 (const avy-goto-subword-0)
78 (const avy-goto-subword-1)
79 (const avy-goto-word-0)
80 (const avy-goto-word-1)
81 (const avy-copy-line)
82 (const avy-copy-region)
83 (const avy-move-line))
84 :value-type (repeat :tag "Keys" character)))
85
86 (defcustom avy-style 'at-full
87 "The default method of displaying the overlays.
88 Use `avy-styles-alist' to customize this per-command."
89 :type '(choice
90 (const :tag "Pre" pre)
91 (const :tag "At" at)
92 (const :tag "At Full" at-full)
93 (const :tag "Post" post)
94 (const :tag "De Bruijn" de-bruijn)))
95
96 (defcustom avy-styles-alist nil
97 "Alist of avy-jump commands to the style for each command.
98 If the commands isn't on the list, `avy-style' is used."
99 :type '(alist
100 :key-type (choice :tag "Command"
101 (const avy-goto-char)
102 (const avy-goto-char-2)
103 (const avy-isearch)
104 (const avy-goto-line)
105 (const avy-goto-subword-0)
106 (const avy-goto-subword-1)
107 (const avy-goto-word-0)
108 (const avy-goto-word-1)
109 (const avy-copy-line)
110 (const avy-copy-region)
111 (const avy-move-line))
112 :value-type (choice
113 (const :tag "Pre" pre)
114 (const :tag "At" at)
115 (const :tag "At Full" at-full)
116 (const :tag "Post" post)
117 (const :tag "De Bruijn" de-bruijn))))
118
119 (defcustom avy-dispatch-alist
120 '((?x . avy-action-kill)
121 (?m . avy-action-mark)
122 (?n . avy-action-copy))
123 "List of actions for `avy-handler-default'.
124
125 Each item is (KEY . ACTION). When KEY not on `avy-keys' is
126 pressed during the dispatch, ACTION is set to replace the default
127 `avy-action-goto' once a candidate is finally selected."
128 :type
129 '(alist
130 :key-type (choice (character :tag "Char"))
131 :value-type (choice
132 (const :tag "Mark" avy-action-mark)
133 (const :tag "Copy" avy-action-copy)
134 (const :tag "Kill" avy-action-kill))))
135
136 (defcustom avy-background nil
137 "When non-nil, a gray background will be added during the selection."
138 :type 'boolean)
139
140 (defcustom avy-all-windows t
141 "Determine the list of windows to consider in search of candidates."
142 :type
143 '(choice
144 (const :tag "All Frames" all-frames)
145 (const :tag "This Frame" t)
146 (const :tag "This Window" nil)))
147
148 (defcustom avy-case-fold-search t
149 "Non-nil if searches should ignore case."
150 :type 'boolean)
151
152 (defcustom avy-word-punc-regexp "[!-/:-@[-`{-~]"
153 "Regexp of punctuation chars that count as word starts for `avy-goto-word-1'.
154 When nil, punctuation chars will not be matched.
155
156 \"[!-/:-@[-\\=`{-~]\" will match all printable punctuation chars."
157 :type 'regexp)
158
159 (defcustom avy-ignored-modes '(image-mode doc-view-mode pdf-view-mode)
160 "List of modes to ignore when searching for candidates.
161 Typically, these modes don't use the text representation.")
162
163 (defvar avy-translate-char-function #'identity
164 "Function to translate user input key into another key.
165 For example, to make SPC do the same as ?a, use
166 \(lambda (c) (if (= c 32) ?a c)).")
167
168 (defface avy-lead-face-0
169 '((t (:foreground "white" :background "#4f57f9")))
170 "Face used for first non-terminating leading chars.")
171
172 (defface avy-lead-face-1
173 '((t (:foreground "white" :background "gray")))
174 "Face used for matched leading chars.")
175
176 (defface avy-lead-face-2
177 '((t (:foreground "white" :background "#f86bf3")))
178 "Face used for leading chars.")
179
180 (defface avy-lead-face
181 '((t (:foreground "white" :background "#e52b50")))
182 "Face used for the leading chars.")
183
184 (defface avy-background-face
185 '((t (:foreground "gray40")))
186 "Face for whole window background during selection.")
187
188 (defface avy-goto-char-timer-face
189 '((t (:inherit highlight)))
190 "Face for matches during reading chars using `avy-goto-char-timer'.")
191
192 (defconst avy-lead-faces '(avy-lead-face
193 avy-lead-face-0
194 avy-lead-face-2
195 avy-lead-face
196 avy-lead-face-0
197 avy-lead-face-2)
198 "Face sequence for `avy--overlay-at-full'.")
199
200 (defvar avy-key-to-char-alist '((left . ?◀)
201 (right . ?▶)
202 (up . ?▲)
203 (down . ?▼)
204 (prior . ?△)
205 (next . ?▽))
206 "An alist from non-character keys to printable chars used in avy overlays.
207 This alist must contain all keys used in `avy-keys' which are not
208 self-inserting keys and thus aren't read as characters.")
209
210 ;;* Internals
211 ;;** Tree
212 (defmacro avy-multipop (lst n)
213 "Remove LST's first N elements and return them."
214 `(if (<= (length ,lst) ,n)
215 (prog1 ,lst
216 (setq ,lst nil))
217 (prog1 ,lst
218 (setcdr
219 (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst))))
220 nil))))
221
222 (defun avy--de-bruijn (keys n)
223 "De Bruijn sequence for alphabet KEYS and subsequences of length N."
224 (let* ((k (length keys))
225 (a (make-list (* n k) 0))
226 sequence)
227 (cl-labels ((db (T p)
228 (if (> T n)
229 (if (eq (% n p) 0)
230 (setq sequence
231 (append sequence
232 (cl-subseq a 1 (1+ p)))))
233 (setf (nth T a) (nth (- T p) a))
234 (db (1+ T) p)
235 (cl-loop for j from (1+ (nth (- T p) a)) to (1- k) do
236 (setf (nth T a) j)
237 (db (1+ T) T)))))
238 (db 1 1)
239 (mapcar (lambda (n)
240 (nth n keys))
241 sequence))))
242
243 (defun avy--path-alist-1 (lst seq-len keys)
244 "Build a De Bruin sequence from LST.
245 SEQ-LEN is how many elements of KEYS it takes to identify a match."
246 (let ((db-seq (avy--de-bruijn keys seq-len))
247 prev-pos prev-seq prev-win path-alist)
248 ;; The De Bruijn seq is cyclic, so append the seq-len - 1 first chars to
249 ;; the end.
250 (setq db-seq (nconc db-seq (cl-subseq db-seq 0 (1- seq-len))))
251 (cl-labels ((subseq-and-pop ()
252 (when (nth (1- seq-len) db-seq)
253 (prog1 (cl-subseq db-seq 0 seq-len)
254 (pop db-seq)))))
255 (while lst
256 (let* ((cur (car lst))
257 (pos (cond
258 ;; ace-window has matches of the form (pos . wnd)
259 ((integerp (car cur)) (car cur))
260 ;; avy-jump have form ((start . end) . wnd)
261 ((consp (car cur)) (caar cur))
262 (t (error "Unexpected match representation: %s" cur))))
263 (win (cdr cur))
264 (path (if prev-pos
265 (let ((diff (if (eq win prev-win)
266 (- pos prev-pos)
267 0)))
268 (when (and (> diff 0) (< diff seq-len))
269 (while (and (nth (1- seq-len) db-seq)
270 (not
271 (eq 0 (cl-search
272 (cl-subseq prev-seq diff)
273 (cl-subseq db-seq 0 seq-len)))))
274 (pop db-seq)))
275 (subseq-and-pop))
276 (subseq-and-pop))))
277 (if (not path)
278 (setq lst nil
279 path-alist nil)
280 (push (cons path (car lst)) path-alist)
281 (setq prev-pos pos
282 prev-seq path
283 prev-win win
284 lst (cdr lst))))))
285 (nreverse path-alist)))
286
287 (defun avy-tree (lst keys)
288 "Coerce LST into a balanced tree.
289 The degree of the tree is the length of KEYS.
290 KEYS are placed appropriately on internal nodes."
291 (let ((len (length keys)))
292 (cl-labels
293 ((rd (ls)
294 (let ((ln (length ls)))
295 (if (< ln len)
296 (cl-pairlis keys
297 (mapcar (lambda (x) (cons 'leaf x)) ls))
298 (let ((ks (copy-sequence keys))
299 res)
300 (dolist (s (avy-subdiv ln len))
301 (push (cons (pop ks)
302 (if (eq s 1)
303 (cons 'leaf (pop ls))
304 (rd (avy-multipop ls s))))
305 res))
306 (nreverse res))))))
307 (rd lst))))
308
309 (defun avy-subdiv (n b)
310 "Distribute N in B terms in a balanced way."
311 (let* ((p (1- (floor (+ (log n b) 1e-6))))
312 (x1 (expt b p))
313 (x2 (* b x1))
314 (delta (- n x2))
315 (n2 (/ delta (- x2 x1)))
316 (n1 (- b n2 1)))
317 (append
318 (make-list n1 x1)
319 (list
320 (- n (* n1 x1) (* n2 x2)))
321 (make-list n2 x2))))
322
323 (defun avy-traverse (tree walker &optional recur-key)
324 "Traverse TREE generated by `avy-tree'.
325 WALKER is a function that takes KEYS and LEAF.
326
327 RECUR-KEY is used in recursion.
328
329 LEAF is a member of LST argument of `avy-tree'.
330
331 KEYS is the path from the root of `avy-tree' to LEAF."
332 (dolist (br tree)
333 (let ((key (cons (car br) recur-key)))
334 (if (eq (cadr br) 'leaf)
335 (funcall walker key (cddr br))
336 (avy-traverse (cdr br) walker key)))))
337
338 (defvar avy-action nil
339 "Function to call at the end of select.")
340
341 (defun avy-handler-default (char)
342 "The default handler for a bad CHAR."
343 (let (dispatch)
344 (if (setq dispatch (assoc char avy-dispatch-alist))
345 (progn
346 (setq avy-action (cdr dispatch))
347 (throw 'done 'restart))
348 (signal 'user-error (list "No such candidate" char))
349 (throw 'done nil))))
350
351 (defvar avy-handler-function 'avy-handler-default
352 "A function to call for a bad `read-key' in `avy-read'.")
353
354 (defvar avy-current-path ""
355 "Store the current incomplete path during `avy-read'.")
356
357 (defun avy-read (tree display-fn cleanup-fn)
358 "Select a leaf from TREE using consecutive `read-char'.
359
360 DISPLAY-FN should take CHAR and LEAF and signify that LEAFs
361 associated with CHAR will be selected if CHAR is pressed. This is
362 commonly done by adding a CHAR overlay at LEAF position.
363
364 CLEANUP-FN should take no arguments and remove the effects of
365 multiple DISPLAY-FN invokations."
366 (catch 'done
367 (setq avy-current-path "")
368 (while tree
369 (let ((avy--leafs nil))
370 (avy-traverse tree
371 (lambda (path leaf)
372 (push (cons path leaf) avy--leafs)))
373 (dolist (x avy--leafs)
374 (funcall display-fn (car x) (cdr x))))
375 (let ((char (funcall avy-translate-char-function (read-key)))
376 branch)
377 (funcall cleanup-fn)
378 (if (setq branch (assoc char tree))
379 (if (eq (car (setq tree (cdr branch))) 'leaf)
380 (throw 'done (cdr tree))
381 (setq avy-current-path
382 (concat avy-current-path (string (avy--key-to-char char)))))
383 (funcall avy-handler-function char))))))
384
385 (defun avy-read-de-bruijn (lst keys)
386 "Select from LST dispatching on KEYS."
387 ;; In theory, the De Bruijn sequence B(k,n) has k^n subsequences of length n
388 ;; (the path length) usable as paths, thus that's the lower bound. Due to
389 ;; partially overlapping matches, not all subsequences may be usable, so it's
390 ;; possible that the path-len must be incremented, e.g., if we're matching
391 ;; for x and a buffer contains xaxbxcx only every second subsequence is
392 ;; usable for the four matches.
393 (catch 'done
394 (let* ((path-len (ceiling (log (length lst) (length keys))))
395 (alist (avy--path-alist-1 lst path-len keys)))
396 (while (not alist)
397 (cl-incf path-len)
398 (setq alist (avy--path-alist-1 lst path-len keys)))
399 (let* ((len (length (caar alist)))
400 (i 0))
401 (setq avy-current-path "")
402 (while (< i len)
403 (dolist (x (reverse alist))
404 (avy--overlay-at-full (reverse (car x)) (cdr x)))
405 (let ((char (funcall avy-translate-char-function (read-key))))
406 (avy--remove-leading-chars)
407 (setq alist
408 (delq nil
409 (mapcar (lambda (x)
410 (when (eq (caar x) char)
411 (cons (cdr (car x)) (cdr x))))
412 alist)))
413 (setq avy-current-path
414 (concat avy-current-path (string (avy--key-to-char char))))
415 (cl-incf i)
416 (unless alist
417 (funcall avy-handler-function char))))
418 (cdar alist)))))
419
420 ;;** Rest
421 (defun avy-window-list ()
422 "Return a list of windows depending on `avy-all-windows'."
423 (cond ((eq avy-all-windows 'all-frames)
424 (cl-mapcan #'window-list (frame-list)))
425
426 ((eq avy-all-windows t)
427 (window-list))
428
429 ((null avy-all-windows)
430 (list (selected-window)))
431
432 (t
433 (error "Unrecognized option: %S" avy-all-windows))))
434
435 (defcustom avy-all-windows-alt t
436 "The alternative `avy-all-windows' for use with \\[universal-argument]."
437 :type '(choice
438 (const :tag "All windows on the current frame" t)
439 (const :tag "All windows on all frames" all-frames)))
440
441 (defmacro avy-dowindows (flip &rest body)
442 "Depending on FLIP and `avy-all-windows' run BODY in each or selected window."
443 (declare (indent 1)
444 (debug (form body)))
445 `(let ((avy-all-windows (if ,flip
446 avy-all-windows-alt
447 avy-all-windows)))
448 (dolist (wnd (avy-window-list))
449 (with-selected-window wnd
450 (unless (memq major-mode avy-ignored-modes)
451 ,@body)))))
452
453 (defmacro avy-with (command &rest body)
454 "Set `avy-keys' according to COMMAND and execute BODY.
455 Set `avy-style' according to COMMMAND as well."
456 (declare (indent 1)
457 (debug (form body)))
458 `(let ((avy-keys (or (cdr (assq ',command avy-keys-alist))
459 avy-keys))
460 (avy-style (or (cdr (assq ',command avy-styles-alist))
461 avy-style)))
462 (setq avy-action nil)
463 ,@body))
464
465 (defun avy-action-goto (pt)
466 "Goto PT."
467 (goto-char pt))
468
469 (defun avy-action-mark (pt)
470 "Mark sexp at PT."
471 (goto-char pt)
472 (set-mark (point))
473 (forward-sexp))
474
475 (defun avy-action-copy (pt)
476 "Copy sexp starting on PT."
477 (save-excursion
478 (let (str)
479 (goto-char pt)
480 (forward-sexp)
481 (setq str (buffer-substring pt (point)))
482 (kill-new str)
483 (message "Copied: %s" str))))
484
485 (defun avy-action-kill (pt)
486 "Kill sexp at PT."
487 (goto-char pt)
488 (forward-sexp)
489 (kill-region pt (point))
490 (message "Killed: %s" (current-kill 0)))
491
492 (defun avy--process (candidates overlay-fn)
493 "Select one of CANDIDATES using `avy-read'.
494 Use OVERLAY-FN to visualize the decision overlay."
495 (unless (and (consp (car candidates))
496 (windowp (cdar candidates)))
497 (setq candidates
498 (mapcar (lambda (x) (cons x (selected-window)))
499 candidates)))
500 (let ((len (length candidates))
501 (cands (copy-sequence candidates))
502 res)
503 (if (= len 0)
504 (message "zero candidates")
505 (if (= len 1)
506 (setq res (car candidates))
507 (unwind-protect
508 (progn
509 (avy--make-backgrounds
510 (avy-window-list))
511 (setq res (if (eq avy-style 'de-bruijn)
512 (avy-read-de-bruijn
513 candidates avy-keys)
514 (avy-read (avy-tree candidates avy-keys)
515 overlay-fn
516 #'avy--remove-leading-chars))))
517 (avy--done)))
518 (cond ((eq res 'restart)
519 (avy--process cands overlay-fn))
520 ;; ignore exit from `avy-handler-function'
521 ((eq res 'exit))
522 (t
523 (avy-push-mark)
524 (when (and (consp res)
525 (windowp (cdr res)))
526 (let* ((window (cdr res))
527 (frame (window-frame window)))
528 (unless (equal frame (selected-frame))
529 (select-frame-set-input-focus frame))
530 (select-window window))
531 (setq res (car res)))
532
533 (funcall (or avy-action 'avy-action-goto)
534 (if (consp res)
535 (car res)
536 res)))))))
537
538 (defvar avy--overlays-back nil
539 "Hold overlays for when `avy-background' is t.")
540
541 (defun avy--make-backgrounds (wnd-list)
542 "Create a dim background overlay for each window on WND-LIST."
543 (when avy-background
544 (setq avy--overlays-back
545 (mapcar (lambda (w)
546 (let ((ol (make-overlay
547 (window-start w)
548 (window-end w)
549 (window-buffer w))))
550 (overlay-put ol 'face 'avy-background-face)
551 (overlay-put ol 'window w)
552 ol))
553 wnd-list))))
554
555 (defun avy--done ()
556 "Clean up overlays."
557 (mapc #'delete-overlay avy--overlays-back)
558 (setq avy--overlays-back nil)
559 (avy--remove-leading-chars))
560
561 (defun avy--next-visible-point ()
562 "Return the next closest point without `invisible' property."
563 (let ((s (point)))
564 (while (and (not (= (point-max) (setq s (next-overlay-change s))))
565 (get-char-property s 'invisible)))
566 s))
567
568 (defun avy--next-invisible-point ()
569 "Return the next closest point with `invisible' property."
570 (let ((s (point)))
571 (while (and (not (= (point-max) (setq s (next-overlay-change s))))
572 (not (get-char-property s 'invisible))))
573 s))
574
575 (defun avy--find-visible-regions (rbeg rend)
576 "Return a list of all visible regions between RBEG and REND."
577 (setq rbeg (max rbeg (point-min)))
578 (setq rend (min rend (point-max)))
579 (when (< rbeg rend)
580 (let (visibles beg)
581 (save-excursion
582 (save-restriction
583 (narrow-to-region rbeg rend)
584 (setq beg (goto-char (point-min)))
585 (while (not (= (point) (point-max)))
586 (goto-char (avy--next-invisible-point))
587 (push (cons beg (point)) visibles)
588 (setq beg (goto-char (avy--next-visible-point))))
589 (nreverse visibles))))))
590
591 (defun avy--regex-candidates (regex &optional beg end pred group)
592 "Return all elements that match REGEX.
593 Each element of the list is ((BEG . END) . WND)
594 When PRED is non-nil, it's a filter for matching point positions.
595 When GROUP is non-nil, (BEG . END) should delimit that regex group."
596 (setq group (or group 0))
597 (let ((case-fold-search (or avy-case-fold-search
598 (string= regex (downcase regex))))
599 candidates)
600 (avy-dowindows current-prefix-arg
601 (dolist (pair (avy--find-visible-regions
602 (or beg (window-start))
603 (or end (window-end (selected-window) t))))
604 (save-excursion
605 (goto-char (car pair))
606 (while (re-search-forward regex (cdr pair) t)
607 (unless (get-char-property (1- (point)) 'invisible)
608 (when (or (null pred)
609 (funcall pred))
610 (push (cons (cons (match-beginning group)
611 (match-end group))
612 wnd) candidates)))))))
613 (nreverse candidates)))
614
615 (defvar avy--overlay-offset 0
616 "The offset to apply in `avy--overlay'.")
617
618 (defvar avy--overlays-lead nil
619 "Hold overlays for leading chars.")
620
621 (defun avy--remove-leading-chars ()
622 "Remove leading char overlays."
623 (mapc #'delete-overlay avy--overlays-lead)
624 (setq avy--overlays-lead nil))
625
626 (defun avy--old-str (pt wnd)
627 "Return a one-char string at PT in WND."
628 (let ((old-str (with-selected-window wnd
629 (buffer-substring pt (1+ pt)))))
630 (if avy-background
631 (propertize old-str 'face 'avy-background-face)
632 old-str)))
633
634 (defun avy--overlay (str beg end wnd &optional compose-fn)
635 "Create an overlay with STR from BEG to END in WND.
636 COMPOSE-FN is a lambda that concatenates the old string at BEG with STR."
637 (let ((eob (with-selected-window wnd (point-max))))
638 (when (<= beg eob)
639 (let* ((beg (+ beg avy--overlay-offset))
640 (ol (make-overlay beg (or end (1+ beg)) (window-buffer wnd)))
641 (old-str (if (eq beg eob) "" (avy--old-str beg wnd)))
642 (os-line-prefix (get-text-property 0 'line-prefix old-str))
643 (os-wrap-prefix (get-text-property 0 'wrap-prefix old-str))
644 other-ol)
645 (when os-line-prefix
646 (add-text-properties 0 1 `(line-prefix ,os-line-prefix) str))
647 (when os-wrap-prefix
648 (add-text-properties 0 1 `(wrap-prefix ,os-wrap-prefix) str))
649 (when (setq other-ol (cl-find-if
650 (lambda (o) (overlay-get o 'goto-address))
651 (overlays-at beg)))
652 (add-text-properties
653 0 (length old-str)
654 `(face ,(overlay-get other-ol 'face)) old-str))
655 (overlay-put ol 'window wnd)
656 (overlay-put ol 'category 'avy)
657 (overlay-put ol (if (eq beg eob)
658 'after-string
659 'display)
660 (funcall
661 (or compose-fn #'concat)
662 str old-str))
663 (push ol avy--overlays-lead)))))
664
665 (defcustom avy-highlight-first nil
666 "When non-nil highlight the first decision char with `avy-lead-face-0'.
667 Do this even when the char is terminating."
668 :type 'boolean)
669
670 (defun avy--key-to-char (c)
671 "If C is no character, translate it using `avy-key-to-char-alist'."
672 (if (characterp c)
673 c
674 (or (cdr (assoc c avy-key-to-char-alist))
675 (error "Unknown key %s" c))))
676
677 (defun avy-candidate-beg (leaf)
678 "Return the start position for LEAF."
679 (cond ((numberp leaf)
680 leaf)
681 ((consp (car leaf))
682 (caar leaf))
683 (t
684 (car leaf))))
685
686 (defun avy-candidate-end (leaf)
687 "Return the end position for LEAF."
688 (cond ((numberp leaf)
689 leaf)
690 ((consp (car leaf))
691 (cdar leaf))
692 (t
693 (car leaf))))
694
695 (defun avy-candidate-wnd (leaf)
696 "Return the window for LEAF."
697 (if (consp leaf)
698 (cdr leaf)
699 (selected-window)))
700
701 (defun avy--overlay-pre (path leaf)
702 "Create an overlay with PATH at LEAF.
703 PATH is a list of keys from tree root to LEAF.
704 LEAF is normally ((BEG . END) . WND)."
705 (let* ((path (mapcar #'avy--key-to-char path))
706 (str (propertize (apply #'string (reverse path))
707 'face 'avy-lead-face)))
708 (when (or avy-highlight-first (> (length str) 1))
709 (set-text-properties 0 1 '(face avy-lead-face-0) str))
710 (setq str (concat
711 (propertize avy-current-path
712 'face 'avy-lead-face-1)
713 str))
714 (avy--overlay
715 str
716 (avy-candidate-beg leaf) nil
717 (avy-candidate-wnd leaf))))
718
719 (defun avy--overlay-at (path leaf)
720 "Create an overlay with PATH at LEAF.
721 PATH is a list of keys from tree root to LEAF.
722 LEAF is normally ((BEG . END) . WND)."
723 (let* ((path (mapcar #'avy--key-to-char path))
724 (str (propertize
725 (string (car (last path)))
726 'face 'avy-lead-face)))
727 (avy--overlay
728 str
729 (avy-candidate-beg leaf) nil
730 (avy-candidate-wnd leaf)
731 (lambda (str old-str)
732 (cond ((string= old-str "\n")
733 (concat str "\n"))
734 ;; add padding for wide-width character
735 ((eq (string-width old-str) 2)
736 (concat str " "))
737 (t
738 str))))))
739
740 (defun avy--overlay-at-full (path leaf)
741 "Create an overlay with PATH at LEAF.
742 PATH is a list of keys from tree root to LEAF.
743 LEAF is normally ((BEG . END) . WND)."
744 (let* ((path (mapcar #'avy--key-to-char path))
745 (str (propertize
746 (apply #'string (reverse path))
747 'face 'avy-lead-face))
748 (len (length path))
749 (beg (avy-candidate-beg leaf))
750 (wnd (cdr leaf))
751 end)
752 (dotimes (i len)
753 (set-text-properties (- len i 1) (- len i)
754 `(face ,(nth i avy-lead-faces))
755 str))
756 (when (eq avy-style 'de-bruijn)
757 (setq str (concat
758 (propertize avy-current-path
759 'face 'avy-lead-face-1)
760 str))
761 (setq len (length str)))
762 (with-selected-window wnd
763 (save-excursion
764 (goto-char beg)
765 (let* ((lep (if (bound-and-true-p visual-line-mode)
766 (save-excursion
767 (end-of-visual-line)
768 (point))
769 (line-end-position)))
770 (len-and-str (avy--update-offset-and-str len str lep)))
771 (setq len (car len-and-str))
772 (setq str (cdr len-and-str))
773 (setq end (if (= beg lep)
774 (1+ beg)
775 (min (+ beg
776 (if (eq (char-after) ?\t)
777 1
778 len))
779 lep)))
780 (when (and (bound-and-true-p visual-line-mode)
781 (> len (- end beg))
782 (not (eq lep beg)))
783 (setq len (- end beg))
784 (let ((old-str (apply #'string (reverse path))))
785 (setq str
786 (substring
787 (propertize
788 old-str
789 'face
790 (if (= (length old-str) 1)
791 'avy-lead-face
792 'avy-lead-face-0))
793 0 len)))))))
794 (avy--overlay
795 str beg end wnd
796 (lambda (str old-str)
797 (cond ((string= old-str "\n")
798 (concat str "\n"))
799 ((string= old-str "\t")
800 (concat str (make-string (max (- tab-width len) 0) ?\ )))
801 (t
802 ;; add padding for wide-width character
803 (if (eq (string-width old-str) 2)
804 (concat str " ")
805 str)))))))
806
807 (defun avy--overlay-post (path leaf)
808 "Create an overlay with PATH at LEAF.
809 PATH is a list of keys from tree root to LEAF.
810 LEAF is normally ((BEG . END) . WND)."
811 (let* ((path (mapcar #'avy--key-to-char path))
812 (str (propertize (apply #'string (reverse path))
813 'face 'avy-lead-face)))
814 (when (or avy-highlight-first (> (length str) 1))
815 (set-text-properties 0 1 '(face avy-lead-face-0) str))
816 (setq str (concat
817 (propertize avy-current-path
818 'face 'avy-lead-face-1)
819 str))
820 (avy--overlay
821 str
822 (avy-candidate-end leaf) nil
823 (avy-candidate-wnd leaf))))
824
825 (defun avy--update-offset-and-str (offset str lep)
826 "Recalculate the length of the new overlay at point.
827
828 OFFSET is the previous overlay length.
829 STR is the overlay string that we wish to add.
830 LEP is the line end position.
831
832 We want to add an overlay between point and END=point+OFFSET.
833 When other overlays already exist between point and END, set
834 OFFSET to be the difference between the start of the first
835 overlay and point. This is equivalent to truncating our new
836 overlay, so that it doesn't intersect with overlays that already
837 exist."
838 (let* ((wnd (selected-window))
839 (beg (point))
840 (oov (delq nil
841 (mapcar
842 (lambda (o)
843 (and (eq (overlay-get o 'category) 'avy)
844 (eq (overlay-get o 'window) wnd)
845 (overlay-start o)))
846 (overlays-in beg (min (+ beg offset) lep))))))
847 (when oov
848 (setq offset (- (apply #'min oov) beg))
849 (setq str (substring str 0 offset)))
850 (let ((other-ov (cl-find-if
851 (lambda (o)
852 (and (eq (overlay-get o 'category) 'avy)
853 (eq (overlay-start o) beg)
854 (not (eq (overlay-get o 'window) wnd))))
855 (overlays-in (point) (min (+ (point) offset) lep)))))
856 (when (and other-ov
857 (> (overlay-end other-ov)
858 (+ beg offset)))
859 (setq str (concat str (buffer-substring
860 (+ beg offset)
861 (overlay-end other-ov))))
862 (setq offset (- (overlay-end other-ov)
863 beg))))
864 (cons offset str)))
865
866 (defun avy--style-fn (style)
867 "Transform STYLE symbol to a style function."
868 (cl-case style
869 (pre #'avy--overlay-pre)
870 (at #'avy--overlay-at)
871 (at-full 'avy--overlay-at-full)
872 (post #'avy--overlay-post)
873 (de-bruijn #'avy--overlay-at-full)
874 (t (error "Unexpected style %S" style))))
875
876 (defun avy--generic-jump (regex window-flip style &optional beg end)
877 "Jump to REGEX.
878 When WINDOW-FLIP is non-nil, do the opposite of `avy-all-windows'.
879 STYLE determines the leading char overlay style.
880 BEG and END delimit the area where candidates are searched."
881 (let ((avy-all-windows
882 (if window-flip
883 (not avy-all-windows)
884 avy-all-windows)))
885 (avy--process
886 (avy--regex-candidates regex beg end)
887 (avy--style-fn style))))
888
889 ;;* Commands
890 ;;;###autoload
891 (defun avy-goto-char (char &optional arg)
892 "Jump to the currently visible CHAR.
893 The window scope is determined by `avy-all-windows' (ARG negates it)."
894 (interactive (list (read-char "char: " t)
895 current-prefix-arg))
896 (avy-with avy-goto-char
897 (avy--generic-jump
898 (if (= 13 char)
899 "\n"
900 (regexp-quote (string char)))
901 arg
902 avy-style)))
903
904 ;;;###autoload
905 (defun avy-goto-char-in-line (char)
906 "Jump to the currently visible CHAR in the current line."
907 (interactive (list (read-char "char: " t)))
908 (avy-with avy-goto-char
909 (avy--generic-jump
910 (regexp-quote (string char))
911 avy-all-windows
912 avy-style
913 (line-beginning-position)
914 (line-end-position))))
915
916 ;;;###autoload
917 (defun avy-goto-char-2 (char1 char2 &optional arg)
918 "Jump to the currently visible CHAR1 followed by CHAR2.
919 The window scope is determined by `avy-all-windows' (ARG negates it)."
920 (interactive (list (read-char "char 1: " t)
921 (read-char "char 2: " t)
922 current-prefix-arg))
923 (avy-with avy-goto-char-2
924 (avy--generic-jump
925 (regexp-quote (string char1 char2))
926 arg
927 avy-style)))
928
929 ;;;###autoload
930 (defun avy-isearch ()
931 "Jump to one of the current isearch candidates."
932 (interactive)
933 (avy-with avy-isearch
934 (let ((avy-background nil))
935 (avy--process
936 (avy--regex-candidates isearch-string)
937 (avy--style-fn avy-style))
938 (isearch-done))))
939
940 ;;;###autoload
941 (defun avy-goto-word-0 (arg)
942 "Jump to a word start.
943 The window scope is determined by `avy-all-windows' (ARG negates it)."
944 (interactive "P")
945 (avy-with avy-goto-word-0
946 (avy--generic-jump "\\b\\sw" arg avy-style)))
947
948 ;;;###autoload
949 (defun avy-goto-word-1 (char &optional arg)
950 "Jump to the currently visible CHAR at a word start.
951 The window scope is determined by `avy-all-windows' (ARG negates it)."
952 (interactive (list (read-char "char: " t)
953 current-prefix-arg))
954 (avy-with avy-goto-word-1
955 (let* ((str (string char))
956 (regex (cond ((string= str ".")
957 "\\.")
958 ((and avy-word-punc-regexp
959 (string-match avy-word-punc-regexp str))
960 (regexp-quote str))
961 (t
962 (concat
963 "\\b"
964 str)))))
965 (avy--generic-jump regex arg avy-style))))
966
967 (declare-function subword-backward "subword")
968 (defvar subword-backward-regexp)
969
970 (defcustom avy-subword-extra-word-chars '(?{ ?= ?} ?* ?: ?> ?<)
971 "A list of characters that should temporarily match \"\\w\".
972 This variable is used by `avy-goto-subword-0' and `avy-goto-subword-1'."
973 :type '(repeat character))
974
975 ;;;###autoload
976 (defun avy-goto-subword-0 (&optional arg predicate)
977 "Jump to a word or subword start.
978
979 The window scope is determined by `avy-all-windows' (ARG negates it).
980
981 When PREDICATE is non-nil it's a function of zero parameters that
982 should return true."
983 (interactive "P")
984 (require 'subword)
985 (avy-with avy-goto-subword-0
986 (let ((case-fold-search nil)
987 (subword-backward-regexp
988 "\\(\\(\\W\\|[[:lower:][:digit:]]\\)\\([!-/:@`~[:upper:]]+\\W*\\)\\|\\W\\w+\\)")
989 candidates)
990 (avy-dowindows arg
991 (let ((syn-tbl (copy-syntax-table)))
992 (dolist (char avy-subword-extra-word-chars)
993 (modify-syntax-entry char "w" syn-tbl))
994 (with-syntax-table syn-tbl
995 (let ((ws (window-start))
996 window-cands)
997 (save-excursion
998 (goto-char (window-end (selected-window) t))
999 (subword-backward)
1000 (while (> (point) ws)
1001 (when (or (null predicate)
1002 (and predicate (funcall predicate)))
1003 (unless (get-char-property (point) 'invisible)
1004 (push (cons (point) (selected-window)) window-cands)))
1005 (subword-backward)))
1006 (setq candidates (nconc candidates window-cands))))))
1007 (avy--process candidates (avy--style-fn avy-style)))))
1008
1009 ;;;###autoload
1010 (defun avy-goto-subword-1 (char &optional arg)
1011 "Jump to the currently visible CHAR at a subword start.
1012 The window scope is determined by `avy-all-windows' (ARG negates it).
1013 The case of CHAR is ignored."
1014 (interactive (list (read-char "char: " t)
1015 current-prefix-arg))
1016 (avy-with avy-goto-subword-1
1017 (let ((char (downcase char)))
1018 (avy-goto-subword-0
1019 arg (lambda () (eq (downcase (char-after)) char))))))
1020
1021 ;;;###autoload
1022 (defun avy-goto-word-or-subword-1 ()
1023 "Forward to `avy-goto-subword-1' or `avy-goto-word-1'.
1024 Which one depends on variable `subword-mode'."
1025 (interactive)
1026 (if (bound-and-true-p subword-mode)
1027 (call-interactively #'avy-goto-subword-1)
1028 (call-interactively #'avy-goto-word-1)))
1029
1030 (defvar visual-line-mode)
1031
1032 (defun avy--line (&optional arg beg end)
1033 "Select a line.
1034 The window scope is determined by `avy-all-windows' (ARG negates it).
1035 Narrow the scope to BEG END."
1036 (let (candidates)
1037 (avy-dowindows arg
1038 (let ((ws (or beg (window-start))))
1039 (save-excursion
1040 (save-restriction
1041 (narrow-to-region ws (or end (window-end (selected-window) t)))
1042 (goto-char (point-min))
1043 (while (< (point) (point-max))
1044 (unless (get-char-property
1045 (max (1- (point)) ws) 'invisible)
1046 (push (cons
1047 (if (eq avy-style 'post)
1048 (line-end-position)
1049 (point))
1050 (selected-window)) candidates))
1051 (if visual-line-mode
1052 (progn
1053 (setq temporary-goal-column 0)
1054 (line-move-visual 1 t))
1055 (forward-line 1)))))))
1056 (let ((avy-action #'identity))
1057 (avy--process (nreverse candidates) (avy--style-fn avy-style)))))
1058
1059 ;;;###autoload
1060 (defun avy-goto-line (&optional arg)
1061 "Jump to a line start in current buffer.
1062
1063 When ARG is 1, jump to lines currently visible, with the option
1064 to cancel to `goto-line' by entering a number.
1065
1066 When ARG is 4, negate the window scope determined by
1067 `avy-all-windows'.
1068
1069 Otherwise, forward to `goto-line' with ARG."
1070 (interactive "p")
1071 (setq arg (or arg 1))
1072 (if (not (memq arg '(1 4)))
1073 (progn
1074 (goto-char (point-min))
1075 (forward-line (1- arg)))
1076 (avy-with avy-goto-line
1077 (let* ((avy-handler-function
1078 (lambda (char)
1079 (if (or (< char ?0)
1080 (> char ?9))
1081 (avy-handler-default char)
1082 (let ((line (read-from-minibuffer
1083 "Goto line: " (string char))))
1084 (when line
1085 (avy-push-mark)
1086 (save-restriction
1087 (widen)
1088 (goto-char (point-min))
1089 (forward-line (1- (string-to-number line))))
1090 (throw 'done 'exit))))))
1091 (r (avy--line (eq arg 4))))
1092 (unless (eq r t)
1093 (avy-action-goto r))))))
1094
1095 ;;;###autoload
1096 (defun avy-goto-line-above ()
1097 "Goto visible line above the cursor."
1098 (interactive)
1099 (let* ((avy-all-windows nil)
1100 (r (avy--line nil (window-start)
1101 (line-beginning-position))))
1102 (unless (eq r t)
1103 (avy-action-goto r))))
1104
1105 ;;;###autoload
1106 (defun avy-goto-line-below ()
1107 "Goto visible line below the cursor."
1108 (interactive)
1109 (let* ((avy-all-windows nil)
1110 (r (avy--line
1111 nil (line-beginning-position 2)
1112 (window-end (selected-window) t))))
1113 (unless (eq r t)
1114 (avy-action-goto r))))
1115
1116 (defcustom avy-line-insert-style 'above
1117 "How to insert the newly copied/cut line."
1118 :type '(choice
1119 (const :tag "Above" above)
1120 (const :tag "Below" below)))
1121
1122 ;;;###autoload
1123 (defun avy-copy-line (arg)
1124 "Copy a selected line above the current line.
1125 ARG lines can be used."
1126 (interactive "p")
1127 (let ((initial-window (selected-window)))
1128 (avy-with avy-copy-line
1129 (let* ((start (avy--line))
1130 (str (buffer-substring-no-properties
1131 start
1132 (save-excursion
1133 (goto-char start)
1134 (move-end-of-line arg)
1135 (point)))))
1136 (select-window initial-window)
1137 (cond ((eq avy-line-insert-style 'above)
1138 (beginning-of-line)
1139 (save-excursion
1140 (insert str "\n")))
1141 ((eq avy-line-insert-style 'below)
1142 (end-of-line)
1143 (insert "\n" str)
1144 (beginning-of-line))
1145 (t
1146 (user-error "Unexpected `avy-line-insert-style'")))))))
1147
1148 ;;;###autoload
1149 (defun avy-move-line (arg)
1150 "Move a selected line above the current line.
1151 ARG lines can be used."
1152 (interactive "p")
1153 (let ((initial-window (selected-window)))
1154 (avy-with avy-move-line
1155 (let ((start (avy--line)))
1156 (save-excursion
1157 (goto-char start)
1158 (kill-whole-line arg))
1159 (select-window initial-window)
1160 (cond ((eq avy-line-insert-style 'above)
1161 (beginning-of-line)
1162 (save-excursion
1163 (insert
1164 (current-kill 0))))
1165 ((eq avy-line-insert-style 'below)
1166 (end-of-line)
1167 (newline)
1168 (save-excursion
1169 (insert (substring (current-kill 0) 0 -1))))
1170 (t
1171 (user-error "Unexpected `avy-line-insert-style'")))))))
1172
1173 ;;;###autoload
1174 (defun avy-copy-region (arg)
1175 "Select two lines and copy the text between them to point.
1176
1177 The window scope is determined by `avy-all-windows' or
1178 `avy-all-windows-alt' when ARG is non-nil."
1179 (interactive "P")
1180 (let ((initial-window (selected-window)))
1181 (avy-with avy-copy-region
1182 (let* ((beg (save-selected-window
1183 (avy--line arg)))
1184 (end (avy--line arg))
1185 (str (buffer-substring-no-properties
1186 beg
1187 (save-excursion
1188 (goto-char end)
1189 (line-end-position)))))
1190 (select-window initial-window)
1191 (cond ((eq avy-line-insert-style 'above)
1192 (beginning-of-line)
1193 (save-excursion
1194 (insert str "\n")))
1195 ((eq avy-line-insert-style 'below)
1196 (end-of-line)
1197 (newline)
1198 (save-excursion
1199 (insert str)))
1200 (t
1201 (user-error "Unexpected `avy-line-insert-style'")))))))
1202
1203 ;;;###autoload
1204 (defun avy-setup-default ()
1205 "Setup the default shortcuts."
1206 (eval-after-load "isearch"
1207 '(define-key isearch-mode-map (kbd "C-'") 'avy-isearch)))
1208
1209 (defcustom avy-timeout-seconds 0.5
1210 "How many seconds to wait for the second char.")
1211
1212 (defun avy--read-candidates ()
1213 "Read as many chars as possible and return their occurences.
1214 At least one char must be read, and then repeatedly one next char
1215 may be read if it is entered before `avy-timeout-seconds'. DEL
1216 deletes the last char entered, and RET exits with the currently
1217 read string immediately instead of waiting for another char for
1218 `avy-timeout-seconds'.
1219 The format of the result is the same as that of `avy--regex-candidates'.
1220 This function obeys `avy-all-windows' setting."
1221 (let ((str "") char break overlays regex)
1222 (unwind-protect
1223 (progn
1224 (while (and (not break)
1225 (setq char
1226 (read-char (format "char%s: "
1227 (if (string= str "")
1228 str
1229 (format " (%s)" str)))
1230 t
1231 (and (not (string= str ""))
1232 avy-timeout-seconds))))
1233 ;; Unhighlight
1234 (dolist (ov overlays)
1235 (delete-overlay ov))
1236 (setq overlays nil)
1237 (cond
1238 ;; Handle RET
1239 ((= char 13)
1240 (setq break t))
1241 ;; Handle DEL
1242 ((= char 127)
1243 (let ((l (length str)))
1244 (when (>= l 1)
1245 (setq str (substring str 0 (1- l))))))
1246 (t
1247 (setq str (concat str (list char)))))
1248 ;; Highlight
1249 (when (>= (length str) 1)
1250 (let ((case-fold-search
1251 (or avy-case-fold-search (string= str (downcase str))))
1252 found)
1253 (avy-dowindows current-prefix-arg
1254 (dolist (pair (avy--find-visible-regions
1255 (window-start)
1256 (window-end (selected-window) t)))
1257 (save-excursion
1258 (goto-char (car pair))
1259 (setq regex (regexp-quote str))
1260 (while (re-search-forward regex (cdr pair) t)
1261 (unless (get-char-property (1- (point)) 'invisible)
1262 (let ((ov (make-overlay
1263 (match-beginning 0)
1264 (match-end 0))))
1265 (setq found t)
1266 (push ov overlays)
1267 (overlay-put ov 'window (selected-window))
1268 (overlay-put ov 'face 'avy-goto-char-timer-face)))))))
1269 ;; No matches at all, so there's surely a typo in the input.
1270 (unless found (beep)))))
1271 (nreverse (mapcar (lambda (ov)
1272 (cons (cons (overlay-start ov)
1273 (overlay-end ov))
1274 (overlay-get ov 'window)))
1275 overlays)))
1276 (dolist (ov overlays)
1277 (delete-overlay ov)))))
1278
1279 ;;;###autoload
1280 (defun avy-goto-char-timer (&optional arg)
1281 "Read one or many consecutive chars and jump to the first one.
1282 The window scope is determined by `avy-all-windows' (ARG negates it)."
1283 (interactive "P")
1284 (let ((avy-all-windows (if arg
1285 (not avy-all-windows)
1286 avy-all-windows)))
1287 (avy-with avy-goto-char-timer
1288 (avy--process
1289 (avy--read-candidates)
1290 (avy--style-fn avy-style)))))
1291
1292 (defvar avy-ring (make-ring 20)
1293 "Hold the window and point history.")
1294
1295 (defun avy-push-mark ()
1296 "Store the current point and window."
1297 (ring-insert avy-ring
1298 (cons (point) (selected-window)))
1299 (unless (region-active-p)
1300 (push-mark)))
1301
1302 (defun avy-pop-mark ()
1303 "Jump back to the last location of `avy-push-mark'."
1304 (interactive)
1305 (let (res)
1306 (condition-case nil
1307 (progn
1308 (while (not (window-live-p
1309 (cdr (setq res (ring-remove avy-ring 0))))))
1310 (let* ((window (cdr res))
1311 (frame (window-frame window)))
1312 (when (and (frame-live-p frame)
1313 (not (eq frame (selected-frame))))
1314 (select-frame-set-input-focus frame))
1315 (select-window window)
1316 (goto-char (car res))))
1317 (error
1318 (set-mark-command 4)))))
1319
1320 (define-obsolete-function-alias
1321 'avy--goto 'identity "0.3.0"
1322 "Don't use this function any more.
1323 `avy--process' will do the jump all by itself.")
1324
1325 (define-obsolete-function-alias 'avy--with-avy-keys 'avy-with "0.3.0")
1326
1327 (provide 'avy)
1328
1329 ;;; avy.el ends here