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