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

   1 ;;; ace-window.el --- Quickly switch windows using `ace-jump-mode'. -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014 Oleh Krehel
   4
   5 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
   6 ;; URL: https://github.com/abo-abo/ace-window
   7 ;; Version: 0.6.0
   8 ;; Package-Requires: ((ace-jump-mode "2.0"))
   9 ;; Keywords: cursor, window, location
  10
  11 ;; This file is not 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 ;; This package uses `ace-jump-mode' machinery to switch between
  29 ;; windows.
  30 ;;
  31 ;; The main function, `ace-window' is meant to replace `other-window'.
  32 ;; If fact, when there are only two windows present, `other-window' is
  33 ;; called.  If there are more, each window will have its first
  34 ;; character highlighted.  Pressing that character will switch to that
  35 ;; window.  Note that unlike `ace-jump-mode', the point position will
  36 ;; not be changed: only current window focus changes.
  37 ;;
  38 ;; To setup this package, just add to your ~.emacs:
  39 ;;
  40 ;;    (global-set-key (kbd "M-p") 'ace-window)
  41 ;;
  42 ;; replacing "M-p"  with an appropriate shortcut.
  43 ;;
  44 ;; Depending on your window usage patterns, you might want to set
  45 ;;
  46 ;;    (setq aw-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l))
  47 ;;
  48 ;; This way they're all on the home row, although the intuitive
  49 ;; ordering is lost.
  50 ;;
  51 ;; When prefixed with one `universal-argument', instead of switching
  52 ;; to selected window, the selected window is swapped with current one.
  53 ;;
  54 ;; When prefixed with two `universal-argument', the selected window is
  55 ;; deleted instead.
  56
  57 ;;; Code:
  58 (require 'ace-jump-mode)
  59
  60 ;; ——— Customization ———————————————————————————————————————————————————————————
  61 (defgroup ace-window nil
  62   "Quickly switch current window."
  63   :group 'convenience
  64   :prefix "aw-")
  65
  66 (defcustom aw-keys '(?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)
  67   "Keys for selecting window."
  68   :group 'ace-window)
  69
  70 (defcustom aw-scope 'global
  71   "The scope used by `ace-window'."
  72   :group 'ace-window
  73   :type '(choice
  74           (const :tag "global" global)
  75           (const :tag "frame" frame)))
  76
  77 (defcustom aw-ignored-buffers '("*Calc Trail*")
  78   "List of buffers to ignore when selecting window."
  79   :group 'ace-window)
  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   :group 'ace-window)
  86
  87 (defcustom aw-background t
  88   "When t, `ace-window' will dim out all buffers temporarily when used.'."
  89   :type 'boolean
  90   :group 'ace-window)
  91
  92 (defun aw-ignored-p (window)
  93   "Return t if WINDOW should be ignored."
  94   (and aw-ignore-on
  95        (member (buffer-name (window-buffer window))
  96                aw-ignored-buffers)))
  97
  98 (defun aw-list-visual-area ()
  99   "Forward to `ace-jump-list-visual-area', removing invisible frames."
 100   (cl-remove-if
 101    (lambda (x)
 102      (let ((f (aj-visual-area-frame x)))
 103        (or (not (and (frame-live-p f)
 104                      (frame-visible-p f)))
 105            (string= "initial_terminal" (terminal-name f))
 106            (aw-ignored-p (aj-visual-area-window x)))))
 107    (ace-jump-list-visual-area)))
 108
 109 (defvar aw--current-op nil
 110   "A function of one argument to call.")
 111
 112 (defun aw--callback ()
 113   "Call `aw--current-op' for the window selected by ace-jump."
 114   (interactive)
 115   (let* ((index (or (cl-position (aref (this-command-keys) 0)
 116                                  aw-keys)
 117                     (length aw-keys)))
 118          (node (nth index (cdr ace-jump-search-tree))))
 119     (cond ((null node)
 120            (message "No such position candidate.")
 121            (ace-jump-done))
 122
 123           ((eq (car node) 'branch)
 124            (let ((old-tree ace-jump-search-tree))
 125              (setq ace-jump-search-tree (cons 'branch (cdr node)))
 126              (ace-jump-update-overlay-in-search-tree
 127               ace-jump-search-tree aw-keys)
 128              (setf (cdr node) nil)
 129              (ace-jump-delete-overlay-in-search-tree old-tree)))
 130
 131           ((eq (car node) 'leaf)
 132            (let ((aj-data (overlay-get (cdr node) 'aj-data)))
 133              (ace-jump-done)
 134              (ace-jump-push-mark)
 135              (run-hooks 'ace-jump-mode-before-jump-hook)
 136              (funcall aw--current-op aj-data))
 137            (run-hooks 'ace-jump-mode-end-hook))
 138
 139           (t
 140            (ace-jump-done)
 141            (error "[AceJump] Internal error: tree node type is invalid")))))
 142
 143 (defun aw--doit (mode-line)
 144   "Select a window and eventually call `aw--current-op' for it.
 145 Set mode line to MODE-LINE during the selection process."
 146   (let* ((ace-jump-mode-scope aw-scope)
 147          (next-window-scope
 148           (cl-case aw-scope
 149             ('global 'visible)
 150             ('frame 'frame)))
 151          (visual-area-list
 152           (sort (aw-list-visual-area)
 153                 'aw-visual-area<))
 154          (visual-area-list
 155           (if (<= (length visual-area-list) 2)
 156               visual-area-list
 157             (cl-remove-if
 158              (lambda (va)
 159                (let ((b (aj-visual-area-buffer va)))
 160                  (with-current-buffer b
 161                    (and buffer-read-only
 162                         (= 0 (buffer-size b))))))
 163              visual-area-list))))
 164     (cl-case (length visual-area-list)
 165       (0)
 166       (1
 167        (if (aw-ignored-p (selected-window))
 168            (other-window 1)
 169          ;; don't get stuck in an empty read-only buffer
 170          (select-window (aj-visual-area-window (car visual-area-list)))))
 171       (2
 172        (if (aw-ignored-p (selected-window))
 173            (other-window 1)
 174          (let ((sw (selected-window))
 175                (w (next-window nil nil next-window-scope)))
 176            (while (aw-ignored-p w)
 177              (select-window w)
 178              (setq w (next-window nil nil next-window-scope)))
 179            (select-window sw)
 180            (funcall aw--current-op
 181                     (make-aj-position
 182                      :offset 0
 183                      :visual-area (make-aj-visual-area
 184                                    :buffer (window-buffer w)
 185                                    :window w
 186                                    :frame (window-frame w)))))))
 187       (t
 188        (let ((candidate-list
 189               (mapcar (lambda (va)
 190                         (let ((b (aj-visual-area-buffer va)))
 191                           ;; ace-jump-mode can't jump if the buffer is empty
 192                           (when (= 0 (buffer-size b))
 193                             (with-current-buffer b
 194                               (insert " "))))
 195                         (make-aj-position
 196                          :offset
 197                          (aw-offset (aj-visual-area-window va))
 198                          :visual-area va))
 199                       visual-area-list)))
 200          ;; create background for each visual area
 201          (if aw-background
 202              (setq ace-jump-background-overlay-list
 203                    (loop for va in visual-area-list
 204                       collect (let* ((w (aj-visual-area-window va))
 205                                      (b (aj-visual-area-buffer va))
 206                                      (ol (make-overlay (window-start w)
 207                                                        (window-end w)
 208                                                        b)))
 209                                 (overlay-put ol 'face 'ace-jump-face-background)
 210                                 ol))))
 211          ;; construct search tree and populate overlay into tree
 212          (setq ace-jump-search-tree
 213                (ace-jump-tree-breadth-first-construct
 214                 (length candidate-list)
 215                 (length aw-keys)))
 216          (ace-jump-populate-overlay-to-search-tree
 217           ace-jump-search-tree candidate-list)
 218          (ace-jump-update-overlay-in-search-tree
 219           ace-jump-search-tree aw-keys)
 220          (setq ace-jump-mode mode-line)
 221          (force-mode-line-update)
 222          ;; turn off helm transient map
 223          (remove-hook 'post-command-hook 'helm--maybe-update-keymap)
 224          ;; override the local key map
 225          (let ((map (make-keymap)))
 226            (dolist (key-code aw-keys)
 227              (define-key map (make-string 1 key-code) 'aw--callback))
 228            (define-key map [t] 'ace-jump-done)
 229            (if (fboundp 'set-transient-map)
 230                (set-transient-map map)
 231              (set-temporary-overlay-map map)))
 232
 233          (add-hook 'mouse-leave-buffer-hook 'ace-jump-done)
 234          (add-hook 'kbd-macro-termination-hook 'ace-jump-done))))))
 235
 236 ;; ——— Interactive —————————————————————————————————————————————————————————————
 237 ;;;###autoload
 238 (defun ace-select-window ()
 239   "Ace select window."
 240   (interactive)
 241   (setq aw--current-op 'aw-switch-to-window)
 242   (aw--doit " Ace - Window"))
 243
 244 ;;;###autoload
 245 (defun ace-delete-window ()
 246   "Ace delete window."
 247   (interactive)
 248   (setq aw--current-op 'aw-delete-window)
 249   (aw--doit " Ace - Delete Window"))
 250
 251 ;;;###autoload
 252 (defun ace-swap-window ()
 253   "Ace swap window."
 254   (interactive)
 255   (setq aw--current-op 'aw-swap-window)
 256   (aw--doit " Ace - Swap Window"))
 257
 258 ;;;###autoload
 259 (defun ace-window (arg)
 260   "Select a window with function `ace-jump-mode'.
 261 Perform an action based on ARG described below.
 262
 263 By default, behaves like extended `other-window'.
 264
 265 Prefixed with one \\[universal-argument], does a swap between the
 266 selected window and the current window, so that the selected
 267 buffer moves to current window (and current buffer moves to
 268 selected window).
 269
 270 Prefixed with two \\[universal-argument]'s, deletes the selected
 271 window."
 272   (interactive "p")
 273   (cl-case arg
 274     (0
 275      (setq aw-ignore-on
 276            (not aw-ignore-on))
 277      (ace-select-window))
 278     (4 (ace-swap-window))
 279     (16 (ace-delete-window))
 280     (t (ace-select-window))))
 281
 282 ;; ——— Utility —————————————————————————————————————————————————————————————————
 283 (defun aw-visual-area< (va1 va2)
 284   "Return true if visual area VA1 is less than VA2.
 285 This is determined by their respective window coordinates.
 286 Windows are numbered top down, left to right."
 287   (let ((f1 (aj-visual-area-frame va1))
 288         (f2 (aj-visual-area-frame va2))
 289         (e1 (window-edges (aj-visual-area-window va1)))
 290         (e2 (window-edges (aj-visual-area-window va2))))
 291     (cond ((string< (frame-parameter f1 'window-id)
 292                     (frame-parameter f2 'window-id))
 293            t)
 294           ((< (car e1) (car e2))
 295            t)
 296           ((> (car e1) (car e2))
 297            nil)
 298           ((< (cadr e1) (cadr e2))
 299            t))))
 300
 301 (defun aw-switch-to-window (aj-data)
 302   "Switch to the window of `aj-position' structure AJ-DATA."
 303   (let ((frame (aj-position-frame aj-data))
 304         (window (aj-position-window aj-data)))
 305     (when (and (frame-live-p frame)
 306                (not (eq frame (selected-frame))))
 307       (select-frame-set-input-focus frame))
 308     (if (window-live-p window)
 309         (select-window window)
 310       (error "Bad aj-data, aw-delete-window: %S" aj-data))))
 311
 312 (defun aw-delete-window (aj-data)
 313   "Delete window of `aj-position' structure AJ-DATA."
 314   (let ((frame (aj-position-frame aj-data))
 315         (window (aj-position-window aj-data)))
 316     (when (and (frame-live-p frame)
 317                (not (eq frame (selected-frame))))
 318       (select-frame-set-input-focus (window-frame window)))
 319     (if (= 1 (length (window-list)))
 320         (delete-frame frame)
 321       (if (window-live-p window)
 322           (delete-window window)
 323         (error "Bad aj-data, aw-delete-window: %S" aj-data)))))
 324
 325 (defun aw-swap-window (aj-data)
 326   "Swap buffers of current window and that of `aj-position' structure AJ-DATA."
 327   (cl-labels ((swap-windows (window1 window2)
 328                 "Swap the buffers of WINDOW1 and WINDOW2."
 329                 (let ((buffer1 (window-buffer window1))
 330                       (buffer2 (window-buffer window2)))
 331                   (set-window-buffer window1 buffer2)
 332                   (set-window-buffer window2 buffer1)
 333                   (select-window window2))))
 334     (let ((frame (aj-position-frame aj-data))
 335           (window (aj-position-window aj-data))
 336           (this-window (selected-window)))
 337       (when (and (frame-live-p frame)
 338                  (not (eq frame (selected-frame))))
 339         (select-frame-set-input-focus (window-frame window)))
 340       (when (and (window-live-p window)
 341                  (not (eq window this-window)))
 342         (swap-windows this-window window)))))
 343
 344 (defun aw-offset (window)
 345   "Return point in WINDOW that's closest to top left corner.
 346 The point is writable, i.e. it's not part of space after newline."
 347   (let ((h (window-hscroll window))
 348         (beg (window-start window))
 349         (end (window-end window))
 350         (inhibit-field-text-motion t))
 351     (with-current-buffer
 352         (window-buffer window)
 353       (save-excursion
 354         (goto-char beg)
 355         (while (and (< (point) end)
 356                     (< (- (line-end-position)
 357                           (line-beginning-position))
 358                        h))
 359           (forward-line))
 360         (+ (point) h)))))
 361
 362 (provide 'ace-window)
 363
 364 ;;; ace-window.el ends here