avy/avy-jump.el

;;; avy-jump.el --- jump to things tree-style. -*- lexical-binding: t -*-

;; Copyright (C) 2015  Free Software Foundation, Inc.

;; Author: Oleh Krehel
;; URL: https://github.com/abo-abo/avy-jump
;; Version: 0.1.0
;; Keywords: point, location

;; This file is part of GNU Emacs.

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; For a full copy of the GNU General Public License
;; see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; This package offers various commands for navigating to things using `avy'.
;; They are in the "Commands" outline.

;;; Code:
;;* Requires
(require 'avy)

;;* Customization
(defgroup avy-jump nil
  "Jump to things tree-style."
  :group 'convenience
  :prefix "avy-")

(defcustom avy-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)
  "Keys for jumping."
  :type '(repeat character))

(defcustom avy-background nil
  "When non-nil, a gray background will be added during the selection."
  :type 'boolean)

(defcustom avy-word-punc-regexp "[!-/:-@[-`{-~]"
  "Regexp of punctuation characters that should be matched when calling
`avy-goto-word-1' command. When nil, punctuation chars will not be matched.

\"[!-/:-@[-`{-~]\" will match all printable punctuation chars.")

(defface avy-lead-face
  '((t (:foreground "white" :background "#e52b50")))
  "Face used for the leading chars.")

(defface avy-background-face
  '((t (:foreground "gray40")))
  "Face for whole window background during selection.")

;;* Internals
(defcustom avy-all-windows t
  "When non-nil, loop though all windows for candidates."
  :type 'boolean)

(defmacro avy-dowindows (flip &rest body)
  "Depending on FLIP and `avy-all-windows' run BODY in each or selected window."
  (declare (indent 1))
  `(let ((avy-all-windows (if ,flip
                              (not avy-all-windows)
                            avy-all-windows)))
     (dolist (wnd (if avy-all-windows
                      (cons (selected-window)
                            (delete (selected-window) (window-list)))
                    (list (selected-window))))
       (with-selected-window wnd
         (unless (memq major-mode '(image-mode doc-view-mode))
           ,@body)))))

(defun avy--goto (x)
  "Goto X.
X is (POS . WND)
POS is either a position or (BEG . END)."
  (if (null x)
      (message "zero candidates")
    (select-window (cdr x))
    (let ((pt (car x)))
      (when (consp pt)
        (setq pt (car pt)))
      (unless (= pt (point)) (push-mark))
      (goto-char pt))))

(defun avy--process (candidates overlay-fn)
  "Select one of CANDIDATES using `avy-read'."
  (unwind-protect
      (cl-case (length candidates)
	(0
	 nil)
	(1
	 (car candidates))
	(t
	 (avy--make-backgrounds (list (selected-window)))
	 (avy-read (avy-tree candidates avy-keys)
		   overlay-fn
		   #'avy--remove-leading-chars)))
    (avy--done)))

(defvar avy--overlays-back nil
  "Hold overlays for when `avy-background' is t.")

(defun avy--make-backgrounds (wnd-list)
  "Create a dim background overlay for each window on WND-LIST."
  (when avy-background
    (setq avy--overlays-back
          (mapcar (lambda (w)
                    (let ((ol (make-overlay
                               (window-start w)
                               (window-end w)
                               (window-buffer w))))
                      (overlay-put ol 'face 'avy-background-face)
                      ol))
                  wnd-list))))

(defun avy--done ()
  "Clean up overlays."
  (mapc #'delete-overlay avy--overlays-back)
  (setq avy--overlays-back nil)
  (avy--remove-leading-chars))

(defun avy--regex-candidates (regex &optional beg end pred)
  "Return all elements that match REGEX.
Each element of the list is ((BEG . END) . WND)
When PRED is non-nil, it's a filter for matching point positions."
  (let (candidates)
    (avy-dowindows nil
      (let ((we (or end (window-end (selected-window) t))))
        (save-excursion
          (goto-char (or beg (window-start)))
          (while (re-search-forward regex we t)
            (unless (get-char-property (point) 'invisible)
              (when (or (null pred)
                        (funcall pred))
                (push (cons (cons (match-beginning 0)
                                  (match-end 0))
                            wnd) candidates)))))))
    (nreverse candidates)))

(defvar avy--overlay-offset 0
  "The offset to apply in `avy--overlay'.")

(defvar avy--overlays-lead nil
  "Hold overlays for leading chars.")

(defun avy--remove-leading-chars ()
  "Remove leading char overlays."
  (mapc #'delete-overlay avy--overlays-lead)
  (setq avy--overlays-lead nil))

(defun avy--overlay (str pt wnd)
  "Create an overlay with STR at PT in WND."
  (when (<= (1+ pt) (with-selected-window wnd (point-max)))
    (let* ((pt (+ pt avy--overlay-offset))
	   (ol (make-overlay pt (1+ pt) (window-buffer wnd)))
	   (old-str (with-selected-window wnd
		      (buffer-substring pt (1+ pt)))))
      (when avy-background
	(setq old-str (propertize
		       old-str 'face 'avy-background-face)))
      (overlay-put ol 'window wnd)
      (overlay-put ol 'display (concat str old-str))
      (push ol avy--overlays-lead))))

(defun avy--overlay-pre (path leaf)
  "Create an overlay with STR at LEAF.
PATH is a list of keys from tree root to LEAF.
LEAF is ((BEG . END) . WND)."
  (avy--overlay
   (propertize (apply #'string (reverse path))
               'face 'avy-lead-face)
   (cond ((numberp leaf)
          leaf)
         ((consp (car leaf))
          (caar leaf))
         (t
          (car leaf)))
   (if (consp leaf)
       (cdr leaf)
     (selected-window))))

(defun avy--overlay-at (path leaf)
  "Create an overlay with STR at LEAF.
PATH is a list of keys from tree root to LEAF.
LEAF is ((BEG . END) . WND)."
  (let ((str (propertize
              (string (car (last path)))
              'face 'avy-lead-face))
        (pt (if (consp (car leaf))
                (caar leaf)
              (car leaf)))
        (wnd (cdr leaf)))
    (let ((ol (make-overlay pt (1+ pt)
                            (window-buffer wnd)))
          (old-str (with-selected-window wnd
                     (buffer-substring pt (1+ pt)))))
      (when avy-background
        (setq old-str (propertize
                       old-str 'face 'avy-background-face)))
      (overlay-put ol 'window wnd)
      (overlay-put ol 'display (if (string= old-str "\n")
				   (concat str "\n")
				 str))
      (push ol avy--overlays-lead))))

(defun avy--overlay-post (path leaf)
  "Create an overlay with STR at LEAF.
PATH is a list of keys from tree root to LEAF.
LEAF is ((BEG . END) . WND)."
  (avy--overlay
   (propertize (apply #'string (reverse path))
               'face 'avy-lead-face)
   (cond ((numberp leaf)
          leaf)
         ((consp (car leaf))
          (cdar leaf))
         (t
          (car leaf)))
   (if (consp leaf)
       (cdr leaf)
     (selected-window))))

(defun avy--style-fn (style)
  "Transform STYLE symbol to a style function."
  (cl-case style
    (pre #'avy--overlay-pre)
    (at #'avy--overlay-at)
    (post #'avy--overlay-post)
    (t (error "Unexpected style %S" style))))

(defun avy--generic-jump (regex window-flip style)
  "Jump to REGEX.
When WINDOW-FLIP is non-nil, do the opposite of `avy-all-windows'.
STYLE determines the leading char overlay style."
  (let ((avy-all-windows
         (if window-flip
             (not avy-all-windows)
           avy-all-windows)))
    (avy--goto
     (avy--process
      (avy--regex-candidates regex)
      (avy--style-fn style)))))

(defcustom avy-goto-char-style 'pre
  "Method of displaying the overlays for `avy-goto-char' and `avy-goto-char-2'."
  :type '(choice
          (const :tag "Pre" pre)
          (const :tag "At" at)
          (const :tag "Post" post)))

(defcustom avy-goto-word-style 'pre
  "Method of displaying the overlays for `avy-goto-word-0' and `avy-goto-word-0'."
  :type '(choice
          (const :tag "Pre" pre)
          (const :tag "At" at)
          (const :tag "Post" post)))

;;* Commands
;;;###autoload
(defun avy-goto-char (&optional arg)
  "Read one char and jump to it.
The window scope is determined by `avy-all-windows' (ARG negates it)."
  (interactive "P")
  (avy--generic-jump
   (let ((c (read-char "char: ")))
     (if (= 13 c)
	 "\n"
       (regexp-quote (string c))))
   arg
   avy-goto-char-style))

;;;###autoload
(defun avy-goto-char-2 (&optional arg)
  "Read two consecutive chars and jump to the first one.
The window scope is determined by `avy-all-windows' (ARG negates it)."
  (interactive "P")
  (avy--generic-jump
   (regexp-quote (string
		  (read-char "char 1: ")
		  (read-char "char 2: ")))
   arg
   avy-goto-char-style))

;;;###autoload
(defun avy-isearch ()
  "Jump to one of the current isearch candidates."
  (interactive)
  (let* ((candidates
          (avy--regex-candidates isearch-string))
         (avy-background nil)
         (candidate
          (avy--process candidates #'avy--overlay-post)))
    (isearch-done)
    (avy--goto candidate)))

;;;###autoload
(defun avy-goto-word-0 (arg)
  "Jump to a word start.
The window scope is determined by `avy-all-windows' (ARG negates it)."
  (interactive "P")
  (let ((avy-keys (number-sequence ?a ?z)))
    (avy--generic-jump "\\b\\sw" arg avy-goto-word-style)))

;;;###autoload
(defun avy-goto-word-1 (&optional arg)
  "Read one char at word start and jump there.
The window scope is determined by `avy-all-windows' (ARG negates it)."
  (interactive "P")
  (let* ((str (string (read-char "char: ")))
         (regex (cond ((string= str ".")
                       "\\.")
                      ((and avy-word-punc-regexp
                            (string-match avy-word-punc-regexp str))
                       str)
                      (t
                       (concat
                        "\\b"
                        str)))))
    (avy--generic-jump regex arg avy-goto-word-style)))

(declare-function subword-backward "subword")

;;;###autoload
(defun avy-goto-subword-0 (&optional arg predicate)
  "Jump to a word or subword start.

The window scope is determined by `avy-all-windows' (ARG negates it).

When PREDICATE is non-nil it's a function of zero parameters that
should return true."
  (interactive "P")
  (require 'subword)
  (let ((avy-keys (if predicate
                      avy-keys
                    (number-sequence ?a ?z)))
        (case-fold-search nil)
        candidates)
    (avy-dowindows arg
      (let ((ws (window-start)))
        (save-excursion
          (goto-char (window-end (selected-window) t))
          (subword-backward)
          (while (> (point) ws)
            (when (or (null predicate)
                      (and predicate (funcall predicate)))
              (push (cons (point) (selected-window)) candidates))
            (subword-backward)))))
    (avy--goto
     (avy--process candidates (avy--style-fn avy-goto-word-style)))))

;;;###autoload
(defun avy-goto-subword-1 (&optional arg)
  "Prompt for a subword start char and jump there.
The window scope is determined by `avy-all-windows' (ARG negates it).
The case is ignored."
  (interactive "P")
  (let ((char (downcase (read-char "char: "))))
    (avy-goto-subword-0
     arg (lambda () (eq (downcase (char-after)) char)))))

(defun avy--line (&optional arg)
  "Select line in current window."
  (let ((avy-background nil)
        candidates)
    (avy-dowindows arg
      (let ((ws (window-start)))
        (save-excursion
          (save-restriction
            (narrow-to-region ws (window-end (selected-window) t))
            (goto-char (point-min))
            (while (< (point) (point-max))
              (unless (get-char-property
                       (max (1- (point)) ws) 'invisible)
                (push (cons (point) (selected-window)) candidates))
              (forward-line 1))))))
    (avy--process (nreverse candidates) #'avy--overlay-pre)))

;;;###autoload
(defun avy-goto-line (&optional arg)
  "Jump to a line start in current buffer."
  (interactive "P")
  (avy--goto (avy--line arg)))

;;;###autoload
(defun avy-copy-line (arg)
  "Copy a selected line above the current line.
ARG lines can be used."
  (interactive "p")
  (let ((start (car (avy--line))))
    (move-beginning-of-line nil)
    (save-excursion
      (insert
       (buffer-substring-no-properties
        start
        (save-excursion
          (goto-char start)
          (move-end-of-line arg)
          (point)))
       "\n"))))

;;;###autoload
(defun avy-move-line (arg)
  "Move a selected line above the current line.
ARG lines can be used."
  (interactive "p")
  (let ((start (car (avy--line))))
    (move-beginning-of-line nil)
    (save-excursion
      (save-excursion
        (goto-char start)
        (move-end-of-line arg)
        (kill-region start (point)))
      (insert
       (current-kill 0)
       "\n"))))

;;;###autoload
(defun avy-copy-region ()
  "Select two lines and copy the text between them here."
  (interactive)
  (let ((beg (car (avy--line)))
        (end (car (avy--line)))
        (pad (if (bolp) "" "\n")))
    (move-beginning-of-line nil)
    (save-excursion
      (insert
       (buffer-substring-no-properties
        beg
        (save-excursion
          (goto-char end)
          (line-end-position)))
       pad))))

;;;###autoload
(defun avy-setup-default ()
  "Setup the default shortcuts."
  (eval-after-load 'isearch
    '(define-key isearch-mode-map (kbd "C-'") 'avy-isearch)))

(defcustom avy-timeout-seconds 0.5
  "How many seconds to wait for the second char.")

;;;###autoload
(defun avy-goto-char-timer (&optional arg)
  "Read one or two consecutive chars and jump to the first one.
The window scope is determined by `avy-all-windows' (ARG negates it)."
  (interactive "P")
  (let ((c1 (read-char "char 1: "))
        (c2 (read-char "char 2: " nil avy-timeout-seconds)))
    (avy--generic-jump
     (regexp-quote
      (if c2
          (string c1 c2)
        (string c1)))
     arg
     avy-goto-char-style)))

(define-obsolete-variable-alias 'avi-keys 'avy-keys "0.1.0")
(define-obsolete-variable-alias 'avi-background 'avy-background "0.1.0")
(define-obsolete-variable-alias 'avi-word-punc-regexp 'avy-word-punc-regexp "0.1.0")
(define-obsolete-face-alias 'avi-lead-face 'avy-lead-face "0.1.0")
(define-obsolete-function-alias 'avi--goto 'avy--goto "0.1.0")
(define-obsolete-function-alias 'avi--process 'avy--process "0.1.0")
(define-obsolete-variable-alias 'avi-all-windows 'avy-all-windows "0.1.0")
(define-obsolete-function-alias 'avi--overlay-pre 'avy--overlay-pre "0.1.0")
(define-obsolete-function-alias 'avi--overlay-at 'avy--overlay-at "0.1.0")
(define-obsolete-function-alias 'avi--overlay-post 'avy--overlay-post "0.1.0")
(define-obsolete-function-alias 'avi-goto-char 'avy-goto-char "0.1.0")
(define-obsolete-function-alias 'avi-goto-char-2 'avy-goto-char-2 "0.1.0")
(define-obsolete-function-alias 'avi-isearch 'avy-isearch "0.1.0")
(define-obsolete-function-alias 'avi-goto-word-0 'avy-goto-word-0 "0.1.0")
(define-obsolete-function-alias 'avi-goto-subword-0 'avy-goto-subword-0 "0.1.0")
(define-obsolete-function-alias 'avi-goto-word-1 'avy-goto-word-1 "0.1.0")
(define-obsolete-function-alias 'avi-goto-line 'avy-goto-line "0.1.0")
(define-obsolete-function-alias 'avi-copy-line 'avy-copy-line "0.1.0")
(define-obsolete-function-alias 'avi-move-line 'avy-move-line "0.1.0")
(define-obsolete-function-alias 'avi-copy-region 'avy-copy-region "0.1.0")
(define-obsolete-function-alias 'avi--regex-candidates 'avy--regex-candidates "0.1.0")

(provide 'avy-jump)

;;; avy-jump.el ends here