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 pred)
  79   "Return all elements that match REGEX in WND.
  80 Each element of the list is ((BEG . END) . WND)
  81 When PRED is non-nil, it's a filter for matching point positions."
  82   (setq wnd (or wnd (selected-window)))
  83   (let ((we (or end (window-end (selected-window) t)))
  84         candidates)
  85     (save-window-excursion
  86       (select-window wnd)
  87       (save-excursion
  88         (goto-char (or beg (window-start)))
  89         (while (re-search-forward regex we t)
  90           (when (or (null pred)
  91                     (funcall pred))
  92             (push (cons (cons (match-beginning 0)
  93                               (match-end 0))
  94                         wnd) candidates))))
  95       (nreverse candidates))))
  96
  97 (defvar avi--overlay-offset 0
  98   "The offset to apply in `avi--overlay'.")
  99
 100 (defun avi--overlay (str pt wnd)
 101   "Create an overlay with STR at PT in WND."
 102   (let* ((pt (+ pt avi--overlay-offset))
 103          (ol (make-overlay pt (1+ pt) (window-buffer wnd)))
 104          (old-str (with-selected-window wnd
 105                     (buffer-substring pt (1+ pt)))))
 106     (when avi-background
 107       (setq old-str (propertize
 108                      old-str 'face 'aw-background-face)))
 109     (overlay-put ol 'window wnd)
 110     (overlay-put ol 'display (concat str old-str))
 111     (push ol aw-overlays-lead)))
 112
 113 (defun avi--overlay-pre (path leaf)
 114   "Create an overlay with STR at LEAF.
 115 PATH is a list of keys from tree root to LEAF.
 116 LEAF is ((BEG . END) . WND)."
 117   (avi--overlay
 118    (propertize (apply #'string (reverse path))
 119                'face 'avi-lead-face)
 120    (if (consp (car leaf))
 121        (caar leaf)
 122      (car leaf))
 123    (cdr leaf)))
 124
 125 (defun avi--overlay-at (path leaf)
 126   "Create an overlay with STR at LEAF.
 127 PATH is a list of keys from tree root to LEAF.
 128 LEAF is ((BEG . END) . WND)."
 129   (let ((str (propertize
 130               (string (car (last path)))
 131               'face 'avi-lead-face))
 132         (pt (if (consp (car leaf))
 133                 (caar leaf)
 134               (car leaf)))
 135         (wnd (cdr leaf)))
 136     (let ((ol (make-overlay pt (1+ pt)
 137                             (window-buffer wnd)))
 138           (old-str (with-selected-window wnd
 139                      (buffer-substring pt (1+ pt)))))
 140       (when avi-background
 141         (setq old-str (propertize
 142                        old-str 'face 'aw-background-face)))
 143       (overlay-put ol 'window wnd)
 144       (overlay-put ol 'display str)
 145       (push ol aw-overlays-lead))))
 146
 147 (defun avi--overlay-post (path leaf)
 148   "Create an overlay with STR at LEAF.
 149 PATH is a list of keys from tree root to LEAF.
 150 LEAF is ((BEG . END) . WND)."
 151   (avi--overlay
 152    (propertize (apply #'string (reverse path))
 153                'face 'avi-lead-face)
 154    (if (consp (car leaf))
 155        (cdar leaf)
 156      (car leaf))
 157    (cdr leaf)))
 158
 159 ;;* Commands
 160 ;;;###autoload
 161 (defun avi-goto-char ()
 162   "Read one char and jump to it in current window."
 163   (interactive)
 164   (avi--goto
 165    (avi--process
 166     (avi--regex-candidates
 167      (string (read-char "char: "))
 168      (selected-window))
 169     #'avi--overlay-post)))
 170
 171 ;;;###autoload
 172 (defun avi-goto-char-2 ()
 173   "Read two chars and jump to them in current window."
 174   (interactive)
 175   (avi--goto
 176    (avi--process
 177     (avi--regex-candidates
 178      (string
 179       (read-char "char 1: ")
 180       (read-char "char 2: "))
 181      (selected-window))
 182     #'avi--overlay-post)))
 183
 184 ;;;###autoload
 185 (defun avi-isearch ()
 186   "Jump to one of the current isearch candidates."
 187   (interactive)
 188   (let* ((candidates
 189           (avi--regex-candidates isearch-string))
 190          (avi-background nil)
 191          (candidate
 192           (avi--process candidates #'avi--overlay-post)))
 193     (isearch-done)
 194     (avi--goto candidate)))
 195
 196 ;;;###autoload
 197 (defun avi-goto-word-0 ()
 198   "Jump to a word start in current window."
 199   (interactive)
 200   (let* ((avi-keys (number-sequence ?a ?z))
 201          (candidates (avi--regex-candidates "\\b\\sw")))
 202     (avi--goto
 203      (avi--process candidates #'avi--overlay-pre))))
 204
 205 ;;;###autoload
 206 (defun avi-goto-word-1 ()
 207   "Jump to a word start in current window.
 208 Read one char with which the word should start."
 209   (interactive)
 210   (let ((candidates (avi--regex-candidates
 211                      (concat
 212                       "\\b"
 213                       (string (read-char "char: "))))))
 214     (avi--goto
 215      (avi--process candidates #'avi--overlay-pre))))
 216
 217 (defun avi--line ()
 218   "Select line in current window."
 219   (let ((avi-background nil)
 220         candidates)
 221     (save-excursion
 222       (save-restriction
 223         (narrow-to-region (window-start) (window-end (selected-window) t))
 224         (goto-char (point-min))
 225         (while (< (point) (point-max))
 226           (push (cons (point) (selected-window))
 227                 candidates)
 228           (forward-line 1))))
 229     (avi--process (nreverse candidates) #'avi--overlay-pre)))
 230
 231 ;;;###autoload
 232 (defun avi-goto-line ()
 233   "Jump to a line start in current buffer."
 234   (interactive)
 235   (avi--goto (avi--line)))
 236
 237 ;;;###autoload
 238 (defun avi-copy-line (arg)
 239   "Copy a selected line above the current line.
 240 ARG lines can be used."
 241   (interactive "p")
 242   (let ((start (car (avi--line))))
 243     (move-beginning-of-line nil)
 244     (save-excursion
 245       (insert
 246        (buffer-substring-no-properties
 247         start
 248         (save-excursion
 249           (goto-char start)
 250           (move-end-of-line arg)
 251           (point)))
 252        "\n"))))
 253
 254 ;;;###autoload
 255 (defun avi-move-line (arg)
 256   "Move a selected line above the current line.
 257 ARG lines can be used."
 258   (interactive "p")
 259   (let ((start (car (avi--line))))
 260     (move-beginning-of-line nil)
 261     (save-excursion
 262       (save-excursion
 263         (goto-char start)
 264         (move-end-of-line arg)
 265         (kill-region start (point)))
 266       (insert
 267        (current-kill 0)))))
 268
 269 ;;;###autoload
 270 (defun avi-copy-region ()
 271   "Select two lines and copy the text between them here."
 272   (interactive)
 273   (let ((beg (car (avi--line)))
 274         (end (car (avi--line)))
 275         (pad (if (bolp) "" "\n")))
 276     (move-beginning-of-line nil)
 277     (save-excursion
 278       (insert
 279        (buffer-substring-no-properties
 280         beg
 281         (save-excursion
 282           (goto-char end)
 283           (line-end-position)))
 284        pad))))
 285
 286 (provide 'avy-jump)
 287
 288 ;;; avy-jump.el ends here