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

   1 ;;; avy-jump.el --- jump to things tree-style
   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 'avy)
  30 (require 'ace-window)
  31
  32 ;;* Customization
  33 (defgroup avy-jump nil
  34   "Jump to things tree-style."
  35   :group 'convenience
  36   :prefix "avi-")
  37
  38 (defcustom avi-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)
  39   "Keys for jumping.")
  40
  41 (defcustom avi-background nil
  42   "When non-nil, a gray background will be added during the selection."
  43   :type 'boolean)
  44
  45 (defface avi-lead-face
  46   '((t (:foreground "white" :background "#e52b50")))
  47   "Face used for the leading chars.")
  48
  49 ;;* Internals
  50 (defun avi--goto (x)
  51   "Goto X.
  52 X is (POS . WND)
  53 POS is either a position or (BEG . END)."
  54   (if (null x)
  55       (message "zero candidates")
  56     (select-window (cdr x))
  57     (let ((pt (car x)))
  58       (when (consp pt)
  59         (setq pt (car pt)))
  60       (goto-char pt))))
  61
  62 (defun avi--process (candidates overlay-fn)
  63   "Select one of CANDIDATES using `avy-read'."
  64   (unwind-protect
  65        (let ((aw-background avi-background))
  66          (cl-case (length candidates)
  67            (0
  68             nil)
  69            (1
  70             (car candidates))
  71            (t
  72             (aw--make-backgrounds (list (selected-window)))
  73             (avy-read (avy-tree candidates avi-keys)
  74                       overlay-fn
  75                       #'aw--remove-leading-chars))))
  76     (aw--done)))
  77
  78 (defun avi--regex-candidates (regex &optional wnd beg end)
  79   "Return all elements that match REGEX in WND.
  80 Each element of the list is ((BEG . END) . WND)."
  81   (setq wnd (or wnd (selected-window)))
  82   (let ((we (or end (window-end (selected-window) t)))
  83         candidates)
  84     (save-window-excursion
  85       (select-window wnd)
  86       (save-excursion
  87         (goto-char (or beg (window-start)))
  88         (while (re-search-forward regex we t)
  89           (push (cons (cons (match-beginning 0)
  90                             (match-end 0))
  91                       wnd) candidates)))
  92       (nreverse candidates))))
  93
  94 (defun avi--overlay (str pt wnd)
  95   "Create an overlay with STR at PT in WND."
  96   (let ((ol (make-overlay pt (1+ pt) (window-buffer wnd)))
  97         (old-str (with-selected-window wnd
  98                    (buffer-substring pt (1+ pt)))))
  99     (when avi-background
 100       (setq old-str (propertize
 101                      old-str 'face 'aw-background-face)))
 102     (overlay-put ol 'window wnd)
 103     (overlay-put ol 'display (concat str old-str))
 104     (push ol aw-overlays-lead)))
 105
 106 (defun avi--overlay-pre (path leaf)
 107   "Create an overlay with STR at LEAF.
 108 PATH is a list of keys from tree root to LEAF.
 109 LEAF is ((BEG . END) . WND)."
 110   (avi--overlay
 111    (propertize (apply #'string (reverse path))
 112                'face 'avi-lead-face)
 113    (if (consp (car leaf))
 114        (caar leaf)
 115      (car leaf))
 116    (cdr leaf)))
 117
 118 (defun avi--overlay-post (path leaf)
 119   "Create an overlay with STR at LEAF.
 120 PATH is a list of keys from tree root to LEAF.
 121 LEAF is ((BEG . END) . WND)."
 122   (avi--overlay
 123    (propertize (apply #'string (reverse path))
 124                'face 'avi-lead-face)
 125    (if (consp (car leaf))
 126        (cdar leaf)
 127      (car leaf))
 128    (cdr leaf)))
 129
 130 ;;* Commands
 131 ;;;###autoload
 132 (defun avi-goto-char ()
 133   "Read one char and jump to it in current window."
 134   (interactive)
 135   (avi--goto
 136    (avi--process
 137     (avi--regex-candidates
 138      (string (read-char "char: "))
 139      (selected-window))
 140     #'avi--overlay-post)))
 141
 142 ;;;###autoload
 143 (defun avi-goto-char-2 ()
 144   "Read two chars and jump to them in current window."
 145   (interactive)
 146   (avi--goto
 147    (avi--process
 148     (avi--regex-candidates
 149      (string
 150       (read-char "char 1: ")
 151       (read-char "char 2: "))
 152      (selected-window))
 153     #'avi--overlay-post)))
 154
 155 ;;;###autoload
 156 (defun avi-isearch ()
 157   "Jump to one of the current isearch candidates."
 158   (interactive)
 159   (let* ((candidates
 160           (avi--regex-candidates isearch-string))
 161          (avi-background nil)
 162          (candidate
 163           (avi--process candidates #'avi--overlay-post)))
 164     (isearch-done)
 165     (avi--goto candidate)))
 166
 167 ;;;###autoload
 168 (defun avi-goto-word-0 ()
 169   "Jump to a word start in current window."
 170   (interactive)
 171   (let* ((avi-keys (number-sequence ?a ?z))
 172          (candidates (avi--regex-candidates "\\b\\sw")))
 173     (avi--goto
 174      (avi--process candidates #'avi--overlay-pre))))
 175
 176 ;;;###autoload
 177 (defun avi-goto-word-1 ()
 178   "Jump to a word start in current window.
 179 Read one char with which the word should start."
 180   (interactive)
 181   (let ((candidates (avi--regex-candidates
 182                      (concat
 183                       "\\b"
 184                       (string (read-char "char: "))))))
 185     (avi--goto
 186      (avi--process candidates #'avi--overlay-pre))))
 187
 188 (defun avi--line ()
 189   "Select line in current window."
 190   (let ((avi-background nil)
 191         candidates)
 192     (save-excursion
 193       (save-restriction
 194         (narrow-to-region (window-start) (window-end (selected-window) t))
 195         (goto-char (point-min))
 196         (while (< (point) (point-max))
 197           (push (cons (point) (selected-window))
 198                 candidates)
 199           (forward-line 1))))
 200     (avi--process (nreverse candidates) #'avi--overlay-pre)))
 201
 202 ;;;###autoload
 203 (defun avi-goto-line ()
 204   "Jump to a line start in current buffer."
 205   (interactive)
 206   (avi--goto (avi--line)))
 207
 208 ;;;###autoload
 209 (defun avi-copy-line (arg)
 210   "Copy a selected line above the current line.
 211 ARG lines can be used."
 212   (interactive "p")
 213   (let ((start (car (avi--line))))
 214     (move-beginning-of-line nil)
 215     (save-excursion
 216       (insert
 217        (buffer-substring-no-properties
 218         start
 219         (save-excursion
 220           (goto-char start)
 221           (move-end-of-line arg)
 222           (point)))
 223        "\n"))))
 224
 225 ;;;###autoload
 226 (defun avi-move-line (arg)
 227   "Move a selected line above the current line.
 228 ARG lines can be used."
 229   (interactive "p")
 230   (let ((start (car (avi--line))))
 231     (move-beginning-of-line nil)
 232     (save-excursion
 233       (save-excursion
 234         (goto-char start)
 235         (move-end-of-line arg)
 236         (kill-region start (point)))
 237       (insert
 238        (current-kill 0)))))
 239
 240 ;;;###autoload
 241 (defun avi-copy-region ()
 242   "Select two lines and copy the text between them here."
 243   (interactive)
 244   (let ((beg (car (avi--line)))
 245         (end (car (avi--line)))
 246         (pad (if (bolp) "" "\n")))
 247     (move-beginning-of-line nil)
 248     (save-excursion
 249       (insert
 250        (buffer-substring-no-properties
 251         beg
 252         (save-excursion
 253           (goto-char end)
 254           (line-end-position)))
 255        pad))))
 256
 257 (provide 'avy-jump)
 258
 259 ;;; avy-jump.el ends here