code.delx.au - gnu-emacs-elpa/blob - packages/avy/avy-jump.el

   1 ;;; avy-jump.el --- jump to things tree-style. -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015  Free Software Foundation, Inc.
   4
   5 ;; Author: Oleh Krehel
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; This file is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 3, or (at your option)
  12 ;; any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; For a full copy of the GNU General Public License
  20 ;; see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; This package offers various commands for navigating to things using `avy'.
  25 ;; They are in the "Commands" outline.
  26
  27 ;;; Code:
  28 ;;* Requires
  29 (require 'cl-lib)
  30 (require 'avy)
  31
  32 ;;* Customization
  33 (defgroup avy-jump nil
  34   "Jump to things tree-style."
  35   :group 'convenience
  36   :prefix "avy-")
  37
  38 (defcustom avy-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)
  39   "Default keys for jumping."
  40   :type '(repeat :tag "Keys" character))
  41
  42 (defcustom avy-keys-alist nil
  43   "Alist of avy-jump commands to `avy-keys' overriding the default `avy-keys'."
  44   :type '(alist
  45           :key-type (choice :tag "Command"
  46                      (const avy-goto-char)
  47                      (const avy-goto-char-2)
  48                      (const avy-isearch)
  49                      (const avy-goto-line)
  50                      (const avy-goto-subword-0)
  51                      (const avy-goto-subword-1)
  52                      (const avy-goto-word-0)
  53                      (const avy-goto-word-1)
  54                      (const avy-copy-line)
  55                      (const avy-copy-region)
  56                      (const avy-move-line))
  57           :value-type (repeat :tag "Keys" character)))
  58
  59 (defcustom avy-style 'pre
  60   "The default method of displaying the overlays.
  61 Use `avy-styles-alist' to customize this per-command."
  62   :type '(choice
  63           (const :tag "Pre" pre)
  64           (const :tag "At" at)
  65           (const :tag "At Full" at-full)
  66           (const :tag "Post" post)))
  67
  68 (defcustom avy-styles-alist nil
  69   "Alist of avy-jump commands to the style for each command.
  70 If the commands isn't on the list, `avy-style' is used."
  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 (choice
  85                        (const :tag "Pre" pre)
  86                        (const :tag "At" at)
  87                        (const :tag "At Full" at-full)
  88                        (const :tag "Post" post))))
  89
  90 (defmacro avy--with-avy-keys (command &rest body)
  91   "Set `avy-keys' according to COMMAND and execute BODY."
  92   (declare (indent 1))
  93   `(let ((avy-keys (or (cdr (assq ',command avy-keys-alist))
  94                        avy-keys))
  95          (avy-style (or (cdr (assq ',command avy-styles-alist))
  96                         avy-style)))
  97      ,@body))
  98
  99 (defcustom avy-background nil
 100   "When non-nil, a gray background will be added during the selection."
 101   :type 'boolean)
 102
 103 (defcustom avy-word-punc-regexp "[!-/:-@[-`{-~]"
 104   "Regexp of punctuation chars that count as word starts for `avy-goto-word-1.
 105 When nil, punctuation chars will not be matched.
 106
 107 \"[!-/:-@[-`{-~]\" will match all printable punctuation chars."
 108   :type 'regexp)
 109
 110 (defface avy-lead-face
 111   '((t (:foreground "white" :background "#e52b50")))
 112   "Face used for the leading chars.")
 113
 114 (defface avy-background-face
 115   '((t (:foreground "gray40")))
 116   "Face for whole window background during selection.")
 117
 118 ;;* Internals
 119 (defcustom avy-all-windows t
 120   "When non-nil, loop though all windows for candidates."
 121   :type 'boolean)
 122
 123 (defmacro avy-dowindows (flip &rest body)
 124   "Depending on FLIP and `avy-all-windows' run BODY in each or selected window."
 125   (declare (indent 1))
 126   `(let ((avy-all-windows (if ,flip
 127                               (not avy-all-windows)
 128                             avy-all-windows)))
 129      (dolist (wnd (if avy-all-windows
 130                       (cons (selected-window)
 131                             (delete (selected-window) (window-list)))
 132                     (list (selected-window))))
 133        (with-selected-window wnd
 134          (unless (memq major-mode '(image-mode doc-view-mode))
 135            ,@body)))))
 136
 137 (defun avy--goto (x)
 138   "Goto X.
 139 X is (POS . WND)
 140 POS is either a position or (BEG . END)."
 141   (if (null x)
 142       (message "zero candidates")
 143     (select-window (cdr x))
 144     (let ((pt (car x)))
 145       (when (consp pt)
 146         (setq pt (car pt)))
 147       (unless (= pt (point)) (push-mark))
 148       (goto-char pt))))
 149
 150 (defun avy--process (candidates overlay-fn)
 151   "Select one of CANDIDATES using `avy-read'.
 152 Use OVERLAY-FN to visualize the decision overlay."
 153   (unwind-protect
 154        (cl-case (length candidates)
 155          (0
 156           nil)
 157          (1
 158           (car candidates))
 159          (t
 160           (avy--make-backgrounds
 161            (if avy-all-windows
 162                (window-list)
 163              (list (selected-window))))
 164           (avy-read (avy-tree candidates avy-keys)
 165                     overlay-fn
 166                     #'avy--remove-leading-chars)))
 167     (avy--done)))
 168
 169 (defvar avy--overlays-back nil
 170   "Hold overlays for when `avy-background' is t.")
 171
 172 (defun avy--make-backgrounds (wnd-list)
 173   "Create a dim background overlay for each window on WND-LIST."
 174   (when avy-background
 175     (setq avy--overlays-back
 176           (mapcar (lambda (w)
 177                     (let ((ol (make-overlay
 178                                (window-start w)
 179                                (window-end w)
 180                                (window-buffer w))))
 181                       (overlay-put ol 'face 'avy-background-face)
 182                       (overlay-put ol 'window w)
 183                       ol))
 184                   wnd-list))))
 185
 186 (defun avy--done ()
 187   "Clean up overlays."
 188   (mapc #'delete-overlay avy--overlays-back)
 189   (setq avy--overlays-back nil)
 190   (avy--remove-leading-chars))
 191
 192 (defun avy--regex-candidates (regex &optional beg end pred)
 193   "Return all elements that match REGEX.
 194 Each element of the list is ((BEG . END) . WND)
 195 When PRED is non-nil, it's a filter for matching point positions."
 196   (let (candidates)
 197     (avy-dowindows nil
 198       (let ((we (or end (window-end (selected-window) t))))
 199         (save-excursion
 200           (goto-char (or beg (window-start)))
 201           (while (re-search-forward regex we t)
 202             (unless (get-char-property (point) 'invisible)
 203               (when (or (null pred)
 204                         (funcall pred))
 205                 (push (cons (cons (match-beginning 0)
 206                                   (match-end 0))
 207                             wnd) candidates)))))))
 208     (nreverse candidates)))
 209
 210 (defvar avy--overlay-offset 0
 211   "The offset to apply in `avy--overlay'.")
 212
 213 (defvar avy--overlays-lead nil
 214   "Hold overlays for leading chars.")
 215
 216 (defun avy--remove-leading-chars ()
 217   "Remove leading char overlays."
 218   (mapc #'delete-overlay avy--overlays-lead)
 219   (setq avy--overlays-lead nil))
 220
 221 (defun avy--overlay (str pt wnd)
 222   "Create an overlay with STR at PT in WND."
 223   (when (<= (1+ pt) (with-selected-window wnd (point-max)))
 224     (let* ((pt (+ pt avy--overlay-offset))
 225            (ol (make-overlay pt (1+ pt) (window-buffer wnd)))
 226            (old-str (with-selected-window wnd
 227                       (buffer-substring pt (1+ pt)))))
 228       (when avy-background
 229         (setq old-str (propertize
 230                        old-str 'face 'avy-background-face)))
 231       (overlay-put ol 'window wnd)
 232       (overlay-put ol 'display (concat str old-str))
 233       (push ol avy--overlays-lead))))
 234
 235 (defun avy--overlay-pre (path leaf)
 236   "Create an overlay with PATH at LEAF.
 237 PATH is a list of keys from tree root to LEAF.
 238 LEAF is normally ((BEG . END) . WND)."
 239   (avy--overlay
 240    (propertize (apply #'string (reverse path))
 241                'face 'avy-lead-face)
 242    (cond ((numberp leaf)
 243           leaf)
 244          ((consp (car leaf))
 245           (caar leaf))
 246          (t
 247           (car leaf)))
 248    (if (consp leaf)
 249        (cdr leaf)
 250      (selected-window))))
 251
 252 (defun avy--overlay-at (path leaf)
 253   "Create an overlay with PATH at LEAF.
 254 PATH is a list of keys from tree root to LEAF.
 255 LEAF is normally ((BEG . END) . WND)."
 256   (let ((str (propertize
 257               (string (car (last path)))
 258               'face 'avy-lead-face))
 259         (pt (if (consp (car leaf))
 260                 (caar leaf)
 261               (car leaf)))
 262         (wnd (cdr leaf)))
 263     (let ((ol (make-overlay pt (1+ pt)
 264                             (window-buffer wnd)))
 265           (old-str (with-selected-window wnd
 266                      (buffer-substring pt (1+ pt)))))
 267       (when avy-background
 268         (setq old-str (propertize
 269                        old-str 'face 'avy-background-face)))
 270       (overlay-put ol 'window wnd)
 271       (overlay-put ol 'display (if (string= old-str "\n")
 272                                    (concat str "\n")
 273                                  str))
 274       (push ol avy--overlays-lead))))
 275
 276 (defun avy--overlay-at-full (path leaf)
 277   "Create an overlay with PATH at LEAF.
 278 PATH is a list of keys from tree root to LEAF.
 279 LEAF is normally ((BEG . END) . WND)."
 280   (let* ((str (propertize
 281                (apply #'string (reverse path))
 282                'face 'avy-lead-face))
 283          (len (length path))
 284          (pt (if (consp (car leaf))
 285                  (caar leaf)
 286                (car leaf)))
 287          (wnd (cdr leaf)))
 288     (let ((ol (make-overlay pt (+ pt len)
 289                             (window-buffer wnd)))
 290           (old-str (with-selected-window wnd
 291                      (buffer-substring pt (1+ pt)))))
 292       (when avy-background
 293         (setq old-str (propertize
 294                        old-str 'face 'avy-background-face)))
 295       (overlay-put ol 'window wnd)
 296       (overlay-put ol 'display (if (string= old-str "\n")
 297                                    (concat str "\n")
 298                                  str))
 299       (push ol avy--overlays-lead))))
 300
 301 (defun avy--overlay-post (path leaf)
 302   "Create an overlay with PATH at LEAF.
 303 PATH is a list of keys from tree root to LEAF.
 304 LEAF is normally ((BEG . END) . WND)."
 305   (avy--overlay
 306    (propertize (apply #'string (reverse path))
 307                'face 'avy-lead-face)
 308    (cond ((numberp leaf)
 309           leaf)
 310          ((consp (car leaf))
 311           (cdar leaf))
 312          (t
 313           (car leaf)))
 314    (if (consp leaf)
 315        (cdr leaf)
 316      (selected-window))))
 317
 318 (defun avy--style-fn (style)
 319   "Transform STYLE symbol to a style function."
 320   (cl-case style
 321     (pre #'avy--overlay-pre)
 322     (at #'avy--overlay-at)
 323     (at-full 'avy--overlay-at-full)
 324     (post #'avy--overlay-post)
 325     (t (error "Unexpected style %S" style))))
 326
 327 (defun avy--generic-jump (regex window-flip style)
 328   "Jump to REGEX.
 329 When WINDOW-FLIP is non-nil, do the opposite of `avy-all-windows'.
 330 STYLE determines the leading char overlay style."
 331   (let ((avy-all-windows
 332          (if window-flip
 333              (not avy-all-windows)
 334            avy-all-windows)))
 335     (avy--goto
 336      (avy--process
 337       (avy--regex-candidates regex)
 338       (avy--style-fn style)))))
 339
 340 ;;* Commands
 341 ;;;###autoload
 342 (defun avy-goto-char (&optional arg)
 343   "Read one char and jump to it.
 344 The window scope is determined by `avy-all-windows' (ARG negates it)."
 345   (interactive "P")
 346   (avy--with-avy-keys avy-goto-char
 347     (avy--generic-jump
 348      (let ((c (read-char "char: ")))
 349        (if (= 13 c)
 350            "\n"
 351          (regexp-quote (string c))))
 352      arg
 353      avy-style)))
 354
 355 ;;;###autoload
 356 (defun avy-goto-char-2 (&optional arg)
 357   "Read two consecutive chars and jump to the first one.
 358 The window scope is determined by `avy-all-windows' (ARG negates it)."
 359   (interactive "P")
 360   (avy--with-avy-keys avy-goto-char-2
 361     (avy--generic-jump
 362      (regexp-quote (string
 363                     (read-char "char 1: ")
 364                     (read-char "char 2: ")))
 365      arg
 366      avy-style)))
 367
 368 ;;;###autoload
 369 (defun avy-isearch ()
 370   "Jump to one of the current isearch candidates."
 371   (interactive)
 372   (avy--with-avy-keys avy-isearch
 373     (let* ((candidates
 374             (avy--regex-candidates isearch-string))
 375            (avy-background nil)
 376            (candidate
 377             (avy--process candidates #'avy--overlay-post)))
 378       (isearch-done)
 379       (avy--goto candidate))))
 380
 381 ;;;###autoload
 382 (defun avy-goto-word-0 (arg)
 383   "Jump to a word start.
 384 The window scope is determined by `avy-all-windows' (ARG negates it)."
 385   (interactive "P")
 386   (avy--with-avy-keys avy-goto-word-0
 387     (avy--generic-jump "\\b\\sw" arg avy-style)))
 388
 389 ;;;###autoload
 390 (defun avy-goto-word-1 (&optional arg)
 391   "Read one char at word start and jump there.
 392 The window scope is determined by `avy-all-windows' (ARG negates it)."
 393   (interactive "P")
 394   (avy--with-avy-keys avy-goto-word-1
 395     (let* ((str (string (read-char "char: ")))
 396            (regex (cond ((string= str ".")
 397                          "\\.")
 398                         ((and avy-word-punc-regexp
 399                               (string-match avy-word-punc-regexp str))
 400                          str)
 401                         (t
 402                          (concat
 403                           "\\b"
 404                           str)))))
 405       (avy--generic-jump regex arg avy-style))))
 406
 407 (declare-function subword-backward "subword")
 408
 409 ;;;###autoload
 410 (defun avy-goto-subword-0 (&optional arg predicate)
 411   "Jump to a word or subword start.
 412
 413 The window scope is determined by `avy-all-windows' (ARG negates it).
 414
 415 When PREDICATE is non-nil it's a function of zero parameters that
 416 should return true."
 417   (interactive "P")
 418   (require 'subword)
 419   (avy--with-avy-keys avy-goto-subword-0
 420     (let ((case-fold-search nil)
 421           candidates)
 422       (avy-dowindows arg
 423         (let ((ws (window-start)))
 424           (save-excursion
 425             (goto-char (window-end (selected-window) t))
 426             (subword-backward)
 427             (while (> (point) ws)
 428               (when (or (null predicate)
 429                         (and predicate (funcall predicate)))
 430                 (push (cons (point) (selected-window)) candidates))
 431               (subword-backward)))))
 432       (avy--goto
 433        (avy--process candidates (avy--style-fn avy-style))))))
 434
 435 ;;;###autoload
 436 (defun avy-goto-subword-1 (&optional arg)
 437   "Prompt for a subword start char and jump there.
 438 The window scope is determined by `avy-all-windows' (ARG negates it).
 439 The case is ignored."
 440   (interactive "P")
 441   (avy--with-avy-keys avy-goto-subword-1
 442     (let ((char (downcase (read-char "char: "))))
 443       (avy-goto-subword-0
 444        arg (lambda () (eq (downcase (char-after)) char))))))
 445
 446 (defun avy--line (&optional arg)
 447   "Select a line.
 448 The window scope is determined by `avy-all-windows' (ARG negates it)."
 449   (let ((avy-background nil)
 450         candidates)
 451     (avy-dowindows arg
 452       (let ((ws (window-start)))
 453         (save-excursion
 454           (save-restriction
 455             (narrow-to-region ws (window-end (selected-window) t))
 456             (goto-char (point-min))
 457             (while (< (point) (point-max))
 458               (unless (get-char-property
 459                        (max (1- (point)) ws) 'invisible)
 460                 (push (cons (point) (selected-window)) candidates))
 461               (forward-line 1))))))
 462     (avy--process (nreverse candidates) #'avy--overlay-pre)))
 463
 464 ;;;###autoload
 465 (defun avy-goto-line (&optional arg)
 466   "Jump to a line start in current buffer.
 467 The window scope is determined by `avy-all-windows' (ARG negates it)."
 468   (interactive "P")
 469   (avy--with-avy-keys avy-goto-line
 470     (avy--goto (avy--line arg))))
 471
 472 ;;;###autoload
 473 (defun avy-copy-line (arg)
 474   "Copy a selected line above the current line.
 475 ARG lines can be used."
 476   (interactive "p")
 477   (avy--with-avy-keys avy-copy-line
 478     (let ((start (car (avy--line))))
 479       (move-beginning-of-line nil)
 480       (save-excursion
 481         (insert
 482          (buffer-substring-no-properties
 483           start
 484           (save-excursion
 485             (goto-char start)
 486             (move-end-of-line arg)
 487             (point)))
 488          "\n")))))
 489
 490 ;;;###autoload
 491 (defun avy-move-line (arg)
 492   "Move a selected line above the current line.
 493 ARG lines can be used."
 494   (interactive "p")
 495   (avy--with-avy-keys avy-move-line
 496     (let ((start (car (avy--line))))
 497       (move-beginning-of-line nil)
 498       (save-excursion
 499         (save-excursion
 500           (goto-char start)
 501           (move-end-of-line arg)
 502           (kill-region start (point)))
 503         (insert
 504          (current-kill 0)
 505          "\n")))))
 506
 507 ;;;###autoload
 508 (defun avy-copy-region ()
 509   "Select two lines and copy the text between them here."
 510   (interactive)
 511   (avy--with-avy-keys avy-copy-region
 512     (let ((beg (car (avy--line)))
 513           (end (car (avy--line)))
 514           (pad (if (bolp) "" "\n")))
 515       (move-beginning-of-line nil)
 516       (save-excursion
 517         (insert
 518          (buffer-substring-no-properties
 519           beg
 520           (save-excursion
 521             (goto-char end)
 522             (line-end-position)))
 523          pad)))))
 524
 525 ;;;###autoload
 526 (defun avy-setup-default ()
 527   "Setup the default shortcuts."
 528   (eval-after-load "isearch"
 529     '(define-key isearch-mode-map (kbd "C-'") 'avy-isearch)))
 530
 531 (defcustom avy-timeout-seconds 0.5
 532   "How many seconds to wait for the second char.")
 533
 534 ;;;###autoload
 535 (defun avy-goto-char-timer (&optional arg)
 536   "Read one or two consecutive chars and jump to the first one.
 537 The window scope is determined by `avy-all-windows' (ARG negates it)."
 538   (interactive "P")
 539   (let ((c1 (read-char "char 1: "))
 540         (c2 (read-char "char 2: " nil avy-timeout-seconds)))
 541     (avy--generic-jump
 542      (regexp-quote
 543       (if c2
 544           (string c1 c2)
 545         (string c1)))
 546      arg
 547      avy-style)))
 548
 549 (define-obsolete-variable-alias
 550     'avy-goto-char-style 'avy-style "0.1.0"
 551     "Use `avy-style' and `avy-styles-alist' instead.")
 552 (define-obsolete-variable-alias
 553     'avy-goto-word-style 'avy-style "0.1.0"
 554     "Use `avy-style' and `avy-styles-alist' instead.")
 555 (define-obsolete-variable-alias 'avi-keys 'avy-keys "0.1.0")
 556 (define-obsolete-variable-alias 'avi-background 'avy-background "0.1.0")
 557 (define-obsolete-variable-alias 'avi-word-punc-regexp 'avy-word-punc-regexp "0.1.0")
 558 (define-obsolete-face-alias 'avi-lead-face 'avy-lead-face "0.1.0")
 559 (define-obsolete-function-alias 'avi--goto 'avy--goto "0.1.0")
 560 (define-obsolete-function-alias 'avi--process 'avy--process "0.1.0")
 561 (define-obsolete-variable-alias 'avi-all-windows 'avy-all-windows "0.1.0")
 562 (define-obsolete-function-alias 'avi--overlay-pre 'avy--overlay-pre "0.1.0")
 563 (define-obsolete-function-alias 'avi--overlay-at 'avy--overlay-at "0.1.0")
 564 (define-obsolete-function-alias 'avi--overlay-post 'avy--overlay-post "0.1.0")
 565 (define-obsolete-function-alias 'avi-goto-char 'avy-goto-char "0.1.0")
 566 (define-obsolete-function-alias 'avi-goto-char-2 'avy-goto-char-2 "0.1.0")
 567 (define-obsolete-function-alias 'avi-isearch 'avy-isearch "0.1.0")
 568 (define-obsolete-function-alias 'avi-goto-word-0 'avy-goto-word-0 "0.1.0")
 569 (define-obsolete-function-alias 'avi-goto-subword-0 'avy-goto-subword-0 "0.1.0")
 570 (define-obsolete-function-alias 'avi-goto-word-1 'avy-goto-word-1 "0.1.0")
 571 (define-obsolete-function-alias 'avi-goto-line 'avy-goto-line "0.1.0")
 572 (define-obsolete-function-alias 'avi-copy-line 'avy-copy-line "0.1.0")
 573 (define-obsolete-function-alias 'avi-move-line 'avy-move-line "0.1.0")
 574 (define-obsolete-function-alias 'avi-copy-region 'avy-copy-region "0.1.0")
 575 (define-obsolete-function-alias 'avi--regex-candidates 'avy--regex-candidates "0.1.0")
 576
 577 (provide 'avy-jump)
 578
 579 ;;; avy-jump.el ends here