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

   1 ;;; ace-window.el --- Quickly switch windows. -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015  Free Software Foundation, Inc.
   4
   5 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
   6 ;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
   7 ;; URL: https://github.com/abo-abo/ace-window
   8 ;; Version: 0.8.0
   9 ;; Keywords: window, location
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; This file is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; For a full copy of the GNU General Public License
  24 ;; see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; The main function, `ace-window' is meant to replace `other-window'.
  29 ;; If fact, when there are only two windows present, `other-window' is
  30 ;; called.  If there are more, each window will have its first
  31 ;; character highlighted.  Pressing that character will switch to that
  32 ;; window.
  33 ;;
  34 ;; To setup this package, just add to your .emacs:
  35 ;;
  36 ;;    (global-set-key (kbd "M-p") 'ace-window)
  37 ;;
  38 ;; replacing "M-p"  with an appropriate shortcut.
  39 ;;
  40 ;; Depending on your window usage patterns, you might want to set
  41 ;;
  42 ;;    (setq aw-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l))
  43 ;;
  44 ;; This way they're all on the home row, although the intuitive
  45 ;; ordering is lost.
  46 ;;
  47 ;; If you don't want the gray background that makes the red selection
  48 ;; characters stand out more, set this:
  49 ;;
  50 ;;    (setq aw-background nil)
  51 ;;
  52 ;; When prefixed with one `universal-argument', instead of switching
  53 ;; to selected window, the selected window is swapped with current one.
  54 ;;
  55 ;; When prefixed with two `universal-argument', the selected window is
  56 ;; deleted instead.
  57
  58 ;;; Code:
  59 (require 'avy)
  60 (require 'ring)
  61
  62 ;;* Customization
  63 (defgroup ace-window nil
  64   "Quickly switch current window."
  65   :group 'convenience
  66   :prefix "aw-")
  67
  68 (defcustom aw-keys '(?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)
  69   "Keys for selecting window.")
  70
  71 (defcustom aw-scope 'global
  72   "The scope used by `ace-window'."
  73   :type '(choice
  74           (const :tag "global" global)
  75           (const :tag "frame" frame)))
  76
  77 (defcustom aw-ignored-buffers '("*Calc Trail*" "*LV*")
  78   "List of buffers to ignore when selecting window."
  79   :type '(repeat string))
  80
  81 (defcustom aw-ignore-on t
  82   "When t, `ace-window' will ignore `aw-ignored-buffers'.
  83 Use M-0 `ace-window' to toggle this value."
  84   :type 'boolean)
  85
  86 (defcustom aw-background t
  87   "When t, `ace-window' will dim out all buffers temporarily when used.'."
  88   :type 'boolean)
  89
  90 (defcustom aw-leading-char-style 'char
  91   "Style of the leading char overlay."
  92   :type '(choice
  93           (const :tag "single char" 'char)
  94           (const :tag "full path" 'path)))
  95
  96 (defface aw-leading-char-face
  97     '((((class color)) (:foreground "red"))
  98       (((background dark)) (:foreground "gray100"))
  99       (((background light)) (:foreground "gray0"))
 100       (t (:foreground "gray100" :underline nil)))
 101   "Face for each window's leading char.")
 102
 103 (defface aw-background-face
 104   '((t (:foreground "gray40")))
 105   "Face for whole window background during selection.")
 106
 107 (defface aw-mode-line-face
 108     '((t (:inherit mode-line-buffer-id)))
 109   "Face used for displaying the ace window key in the mode-line.")
 110
 111 ;;* Implementation
 112 (defun aw-ignored-p (window)
 113   "Return t if WINDOW should be ignored."
 114   (and aw-ignore-on
 115        (member (buffer-name (window-buffer window))
 116                aw-ignored-buffers)))
 117
 118 (defun aw-window-list ()
 119   "Return the list of interesting windows."
 120   (sort
 121    (cl-remove-if
 122     (lambda (w)
 123       (let ((f (window-frame w))
 124             (b (window-buffer w)))
 125         (or (not (and (frame-live-p f)
 126                       (frame-visible-p f)))
 127             (string= "initial_terminal" (terminal-name f))
 128             (aw-ignored-p w)
 129             (with-current-buffer b
 130               (and buffer-read-only
 131                    (= 0 (buffer-size b)))))))
 132     (cl-case aw-scope
 133       (global
 134        (cl-mapcan #'window-list (frame-list)))
 135       (frame
 136        (window-list))
 137       (t
 138        (error "Invalid `aw-scope': %S" aw-scope))))
 139    'aw-window<))
 140
 141 (defvar aw-overlays-lead nil
 142   "Hold overlays for leading chars.")
 143
 144 (defvar aw-overlays-back nil
 145   "Hold overlays for when `aw-background' is t.")
 146
 147 (defvar ace-window-mode nil
 148   "Minor mode during the selection process.")
 149
 150 ;; register minor mode
 151 (or (assq 'ace-window-mode minor-mode-alist)
 152     (nconc minor-mode-alist
 153            (list '(ace-window-mode ace-window-mode))))
 154
 155 (defun aw--done ()
 156   "Clean up mode line and overlays."
 157   ;; mode line
 158   (setq ace-window-mode nil)
 159   (force-mode-line-update)
 160   ;; background
 161   (mapc #'delete-overlay aw-overlays-back)
 162   (setq aw-overlays-back nil)
 163   (aw--remove-leading-chars))
 164
 165 (defun aw--lead-overlay (path leaf)
 166   "Create an overlay using PATH at LEAF.
 167 LEAF is (PT . WND)."
 168   (let* ((pt (car leaf))
 169          (wnd (cdr leaf))
 170          (ol (make-overlay pt (1+ pt) (window-buffer wnd)))
 171          (old-str (with-selected-window wnd
 172                     (buffer-substring pt (1+ pt))))
 173          (new-str
 174           (concat
 175            (cl-case aw-leading-char-style
 176              (char
 177               (apply #'string (last path)))
 178              (path
 179               (apply #'string (reverse path)))
 180              (t
 181               (error "Bad `aw-leading-char-style': %S"
 182                      aw-leading-char-style)))
 183            (cond ((string-equal old-str "\t")
 184                   (make-string (1- tab-width) ?\ ))
 185                  ((string-equal old-str "\n")
 186                   "\n")
 187                  (t
 188                   (make-string
 189                    (max 0 (1- (string-width old-str)))
 190                    ?\ ))))))
 191     (overlay-put ol 'face 'aw-leading-char-face)
 192     (overlay-put ol 'window wnd)
 193     (overlay-put ol 'display new-str)
 194     (push ol aw-overlays-lead)))
 195
 196 (defun aw--remove-leading-chars ()
 197   "Remove leading char overlays."
 198   (mapc #'delete-overlay aw-overlays-lead)
 199   (setq aw-overlays-lead nil))
 200
 201 (defun aw--make-backgrounds (wnd-list)
 202   "Create a dim background overlay for each window on WND-LIST."
 203   (when aw-background
 204     (setq aw-overlays-back
 205           (mapcar (lambda (w)
 206                     (let ((ol (make-overlay
 207                                (window-start w)
 208                                (window-end w)
 209                                (window-buffer w))))
 210                       (overlay-put ol 'face 'aw-background-face)
 211                       ol))
 212                   wnd-list))))
 213
 214 (defvar aw--flip-keys nil
 215   "Pre-processed `aw-flip-keys'.")
 216
 217 (defcustom aw-flip-keys '("n")
 218   "Keys which should select the last window."
 219   :set (lambda (sym val)
 220          (set sym val)
 221          (setq aw--flip-keys
 222                (mapcar (lambda (x) (aref (kbd x) 0)) val))))
 223
 224 (defun aw-select (mode-line)
 225   "Return a selected other window.
 226 Amend MODE-LINE to the mode line for the duration of the selection."
 227   (let ((start-window (selected-window))
 228         (next-window-scope (cl-case aw-scope
 229                              ('global 'visible)
 230                              ('frame 'frame)))
 231         (wnd-list (aw-window-list))
 232         final-window)
 233     (cl-case (length wnd-list)
 234       (0
 235        start-window)
 236       (1
 237        (car wnd-list))
 238       (2
 239        (setq final-window (next-window nil nil next-window-scope))
 240        (while (and (aw-ignored-p final-window)
 241                    (not (equal final-window start-window)))
 242          (setq final-window (next-window final-window nil next-window-scope)))
 243        final-window)
 244       (t
 245        (let ((candidate-list
 246               (mapcar (lambda (wnd)
 247                         ;; can't jump if the buffer is empty
 248                         (with-current-buffer (window-buffer wnd)
 249                           (when (= 0 (buffer-size))
 250                             (insert " ")))
 251                         (cons (aw-offset wnd) wnd))
 252                       wnd-list)))
 253          (aw--make-backgrounds wnd-list)
 254          (setq ace-window-mode mode-line)
 255          (force-mode-line-update)
 256          ;; turn off helm transient map
 257          (remove-hook 'post-command-hook 'helm--maybe-update-keymap)
 258          (unwind-protect
 259               (condition-case err
 260                   (or (cdr (avy-read (avy-tree candidate-list aw-keys)
 261                                      #'aw--lead-overlay
 262                                      #'aw--remove-leading-chars))
 263                       start-window)
 264                 (error
 265                  (if (memq (nth 2 err) aw--flip-keys)
 266                      (aw--pop-window)
 267                    (signal (car err) (cdr err)))))
 268            (aw--done)))))))
 269
 270 ;;* Interactive
 271 ;;;###autoload
 272 (defun ace-select-window ()
 273   "Ace select window."
 274   (interactive)
 275   (aw-switch-to-window
 276    (aw-select " Ace - Window")))
 277
 278 ;;;###autoload
 279 (defun ace-delete-window ()
 280   "Ace delete window."
 281   (interactive)
 282   (aw-delete-window
 283    (aw-select " Ace - Delete Window")))
 284
 285 ;;;###autoload
 286 (defun ace-swap-window ()
 287   "Ace swap window."
 288   (interactive)
 289   (aw-swap-window
 290    (aw-select " Ace - Swap Window")))
 291
 292 ;;;###autoload
 293 (defun ace-maximize-window ()
 294   "Ace maximize window."
 295   (interactive)
 296   (select-window
 297    (aw-select " Ace - Maximize Window"))
 298   (delete-other-windows))
 299
 300 ;;;###autoload
 301 (defun ace-window (arg)
 302   "Select a window.
 303 Perform an action based on ARG described below.
 304
 305 By default, behaves like extended `other-window'.
 306
 307 Prefixed with one \\[universal-argument], does a swap between the
 308 selected window and the current window, so that the selected
 309 buffer moves to current window (and current buffer moves to
 310 selected window).
 311
 312 Prefixed with two \\[universal-argument]'s, deletes the selected
 313 window."
 314   (interactive "p")
 315   (cl-case arg
 316     (0
 317      (setq aw-ignore-on
 318            (not aw-ignore-on))
 319      (ace-select-window))
 320     (4 (ace-swap-window))
 321     (16 (ace-delete-window))
 322     (t (ace-select-window))))
 323
 324 ;;* Utility
 325 (defun aw-window< (wnd1 wnd2)
 326   "Return true if WND1 is less than WND2.
 327 This is determined by their respective window coordinates.
 328 Windows are numbered top down, left to right."
 329   (let ((f1 (window-frame wnd1))
 330         (f2 (window-frame wnd2))
 331         (e1 (window-edges wnd1))
 332         (e2 (window-edges wnd2)))
 333     (cond ((string< (frame-parameter f1 'window-id)
 334                     (frame-parameter f2 'window-id))
 335            t)
 336           ((< (car e1) (car e2))
 337            t)
 338           ((> (car e1) (car e2))
 339            nil)
 340           ((< (cadr e1) (cadr e2))
 341            t))))
 342
 343 (defvar aw--window-ring (make-ring 10)
 344   "Hold the window switching history.")
 345
 346 (defun aw--push-window (window)
 347   "Store WINDOW to `aw--window-ring'."
 348   (when (or (zerop (ring-length aw--window-ring))
 349             (not (equal
 350                   (ring-ref aw--window-ring 0)
 351                   window)))
 352     (ring-insert aw--window-ring (selected-window))))
 353
 354 (defun aw--pop-window ()
 355   "Return the removed top of `aw--window-ring'."
 356   (let (res)
 357     (condition-case nil
 358         (while (not (window-live-p
 359                      (setq res (ring-remove aw--window-ring 0)))))
 360       (error
 361        (error "No previous windows stored")))
 362     res))
 363
 364 (defun aw-switch-to-window (window)
 365   "Switch to the window WINDOW."
 366   (let ((frame (window-frame window)))
 367     (when (and (frame-live-p frame)
 368                (not (eq frame (selected-frame))))
 369       (select-frame-set-input-focus frame))
 370     (if (window-live-p window)
 371         (progn
 372           (aw--push-window (selected-window))
 373           (select-window window))
 374       (error "Got a dead window %S" window))))
 375
 376 (defun aw-flip-window ()
 377   "Switch to the window you were previously in."
 378   (interactive)
 379   (aw-switch-to-window (aw--pop-window)))
 380
 381 (defun aw-delete-window (window)
 382   "Delete window WINDOW."
 383   (let ((frame (window-frame window)))
 384     (when (and (frame-live-p frame)
 385                (not (eq frame (selected-frame))))
 386       (select-frame-set-input-focus (window-frame window)))
 387     (if (= 1 (length (window-list)))
 388         (delete-frame frame)
 389       (if (window-live-p window)
 390           (delete-window window)
 391         (error "Got a dead window %S" window)))))
 392
 393 (defun aw-swap-window (window)
 394   "Swap buffers of current window and WINDOW."
 395   (cl-labels ((swap-windows (window1 window2)
 396                 "Swap the buffers of WINDOW1 and WINDOW2."
 397                 (let ((buffer1 (window-buffer window1))
 398                       (buffer2 (window-buffer window2)))
 399                   (set-window-buffer window1 buffer2)
 400                   (set-window-buffer window2 buffer1)
 401                   (select-window window2))))
 402     (let ((frame (window-frame window))
 403           (this-window (selected-window)))
 404       (when (and (frame-live-p frame)
 405                  (not (eq frame (selected-frame))))
 406         (select-frame-set-input-focus (window-frame window)))
 407       (when (and (window-live-p window)
 408                  (not (eq window this-window)))
 409         (aw--push-window this-window)
 410         (swap-windows this-window window)))))
 411
 412 (defun aw-offset (window)
 413   "Return point in WINDOW that's closest to top left corner.
 414 The point is writable, i.e. it's not part of space after newline."
 415   (let ((h (window-hscroll window))
 416         (beg (window-start window))
 417         (end (window-end window))
 418         (inhibit-field-text-motion t))
 419     (with-current-buffer
 420         (window-buffer window)
 421       (save-excursion
 422         (goto-char beg)
 423         (while (and (< (point) end)
 424                     (< (- (line-end-position)
 425                           (line-beginning-position))
 426                        h))
 427           (forward-line))
 428         (+ (point) h)))))
 429
 430 ;;* Mode line
 431 ;;;###autoload
 432 (define-minor-mode ace-window-display-mode
 433     "Minor mode for showing the ace window key in the mode line."
 434   :global t
 435   (if ace-window-display-mode
 436       (progn
 437         (aw-update)
 438         (set-default
 439          'mode-line-format
 440          `((ace-window-display-mode
 441             (:eval (window-parameter (selected-window) 'ace-window-path)))
 442            ,@(assq-delete-all
 443               'ace-window-display-mode
 444               (default-value 'mode-line-format))))
 445         (force-mode-line-update t)
 446         (add-hook 'window-configuration-change-hook 'aw-update))
 447     (set-default
 448      'mode-line-format
 449      (assq-delete-all
 450       'ace-window-display-mode
 451       (default-value 'mode-line-format)))
 452     (remove-hook 'window-configuration-change-hook 'aw-update)))
 453
 454 (defun aw-update ()
 455   "Update ace-window-path window parameter for all windows."
 456   (avy-traverse
 457    (avy-tree (aw-window-list) aw-keys)
 458    (lambda (path leaf)
 459      (set-window-parameter
 460       leaf 'ace-window-path
 461       (propertize
 462        (apply #'string (reverse path))
 463        'face 'aw-mode-line-face)))))
 464
 465 (provide 'ace-window)
 466
 467 ;;; ace-window.el ends here