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