--- /dev/null
+;;; guide-key.el --- Guide the following key bindings automatically and dynamically
+
+;; Copyright (C) 2012, 2013 Tsunenobu Kai
+
+;; Author: Tsunenobu Kai <kai2nenobuNOSPAMgmail.com>
+;; URL: https://github.com/kai2nenobu/guide-key
+;; Version: 20140828.807
+;; X-Original-Version: 1.2.3
+;; Package-Requires: ((popwin "0.3.0"))
+;; Keywords: help convenience
+
+;; This program 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 of the License, 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Overview:
+;;
+;; guide-key.el displays the available key bindings automatically and dynamically.
+;; guide-key aims to be an alternative of one-key.el.
+;;
+;; Here are some features of this library.
+;; - guide-key automatically pops up the keys following your favorite
+;; prefixes. Moreover, even if you change key bindings, guide-key follows the
+;; change dynamically.
+;; - guide-key can highlight particular commands. This makes it easy to find a
+;; command you are looking for, and to learn its key binding.
+;; - guide-key doesn't overwrite existing commands and key bindings, so there
+;; is no interference with `describe-key' and `describe-bindings'.
+;;
+;;
+;; Installation:
+;;
+;; I added guide-key to MELPA. You can install guide-key with package.el.
+;; Because guide-key depends on popwin.el, popwin.el is also installed.
+;;
+;; If you don't have package.el, please download popwin.el and guide-key.el
+;; directly from https://github.com/m2ym/popwin-el and
+;; https://github.com/kai2nenobu/guide-key, and then put them in your
+;; `load-path'.
+;;
+;;
+;; Basic usage:
+;;
+;; You just add your favorite prefix keys to `guide-key/guide-key-sequence'
+;; as below.
+;;
+;; (require 'guide-key)
+;; (setq guide-key/guide-key-sequence '("C-x r" "C-x 4"))
+;; (guide-key-mode 1) ; Enable guide-key-mode
+;;
+;; When you press these prefix keys, key bindings are automatically
+;; popped up after a short delay (1 second by default).
+;;
+;; guide-key can highlight commands which match a specified regular expression.
+;; Key bindings following "C-x r" are rectangle family and register family.
+;; If you want to highlight only rectangle family commands, put this setting
+;; in your init.el.
+;;
+;; (setq guide-key/highlight-command-regexp "rectangle")
+;;
+;; This feature makes it easy to find commands and learn their key bindings. If
+;; you want to highlight both rectangle family and register family, set an
+;; adequate regular expression like this.
+;;
+;; (setq guide-key/highlight-command-regexp "rectangle\\|register")
+;;
+;; Moreover, prefix commands are automatically highlighted.
+;;
+;; Depending on your level of emacs experience, you may want a shorter or
+;; longer delay between pressing a key and the appearance of the guide
+;; buffer. This can be controlled by setting `guide-key/idle-delay':
+;;
+;; (setq guide-key/idle-delay 0.1)
+;;
+;; The guide buffer is displayed only when you pause between keystrokes
+;; for longer than this delay, so it will keep out of your way when you
+;; are typing key sequences that you already know well.
+;;
+;; I've confirmed that guide-key works well in these environments.
+;; - Emacs 24.2, Ubuntu 12.04 or Windows 7 64bit
+;; - Emacs 23.3, Ubuntu 12.04 or Windows 7 64bit
+;; - Emacs 22.3, Windows 7 64bit
+;; - Emacs 24.3.1, OS X 10.9
+;; If popwin works, I think guide-key will work as well. You can use
+;; guide-key with Emacs working in terminal.
+;;
+;;
+;; Advanced usage:
+;;
+;; It is bothering to add many prefixes to `guide-key/guide-key-sequence'.
+;; `guide-key/recursive-key-sequence-flag' releases you from this problem.
+;; If `guide-key/recursive-key-sequence-flag' is non-nil, guide-key checks a
+;; input key sequence recursively. That is, if "C-x 8 ^" is an input key
+;; sequence, guide-key checks whether `guide-key/guide-key-sequence' includes
+;; "C-x 8" and "C-x".
+;;
+;; For example, if you configure as below,
+;;
+;; (setq guide-key/guide-key-sequence '("C-x"))
+;; (setq guide-key/recursive-key-sequence-flag t)
+;;
+;; the guide buffer is popped up when you input "C-x r", "C-x 8" and
+;; any other prefixes following "C-x".
+;;
+;;
+;; You can add extra settings in a particular mode. Please use
+;; `guide-key/add-local-guide-key-sequence',
+;; `guide-key/add-local-highlight-command-regexp' and the hook of
+;; that mode.
+;;
+;;
+;; This code is a example of org-mode.
+;;
+;; (defun guide-key/my-hook-function-for-org-mode ()
+;; (guide-key/add-local-guide-key-sequence "C-c")
+;; (guide-key/add-local-guide-key-sequence "C-c C-x")
+;; (guide-key/add-local-highlight-command-regexp "org-"))
+;; (add-hook 'org-mode-hook 'guide-key/my-hook-function-for-org-mode)
+;;
+;; In respect of `guide-key/guide-key-sequence', you can add mode specific key
+;; sequences without `guide-key/add-local-guide-key-sequence'. For example,
+;; configure as below.
+;;
+;; (setq guide-key/guide-key-sequence
+;; '("C-x r" "C-x 4"
+;; (org-mode "C-c C-x")
+;; (outline-minor-mode "C-c @")))
+;;
+;; In this case, if the current major mode is `org-mode', guide key bindings
+;; following "C-c C-x". If `outline-minor-mode' is enabled, guide key bindings
+;; following "C-c @".
+;;
+;;
+;; `guide-key' can work with key-chord.el. If you want to guide key bindings
+;; following key chord, you need to execute
+;; `guide-key/key-chord-hack-on'. Then, add your favorite key chord to
+;; `guide-key/guide-key-sequence' as below.
+;;
+;; (key-chord-define global-map "@4" 'ctl-x-4-prefix)
+;;
+;; (guide-key/key-chord-hack-on)
+;; (setq guide-key/guide-key-sequence '("<key-chord> @ 4" "<key-chord> 4 @"))
+;;
+;; If =guide-key/recursive-key-sequence-flag= is non-nil, more simple.
+;;
+;; (guide-key/key-chord-hack-on)
+;; (setq guide-key/recursive-key-sequence-flag t)
+;; (setq guide-key/guide-key-sequence '("<key-chord>"))
+;;
+;; In this case, key bindings are popped up when you type any of key chords.
+;;
+;; This hack *may be dangerous* because it advices primitive functions;
+;; `this-command-keys' and `this-command-keys-vector'.
+;;
+;;
+;; Here are some functions and variables which control guide-key.
+;; - `guide-key-mode':
+;; guide-key-mode is implemented as a minor mode.
+;; Excuting M-x guide-key-mode toggles whether guide-key is enabled or
+;; not. Because guide-key-mode is a global minor mode, guide-key-mode is
+;; enabled in all buffers or disabled in all buffers.
+;; - `guide-key/popup-window-position':
+;; This variable controls where a guide-key buffer is popped up. A value of
+;; this variable is one of `right', `bottom', `left', `top'. The default
+;; value is `right'.
+;; - `guide-key/polling-time':
+;; This variable controls a polling time. The default value is 0.1 (in seconds).
+;; - `guide-key/idle-delay':
+;; This variable controls the delay between starting a key sequence and
+;; popping up the guide buffer. The default value is 1.0 (in seconds),
+;; which means that guide-key will keep out of your way unless you hesitate
+;; in the middle of a key sequence . Set this to 0.0 to revert to the old
+;; default behavior.
+;; - `guide-key/text-scale-amount':
+;; This variable controls the size of text in guide buffer. The default
+;; value is 0 (it means default size in Emacs). If you want to enlarge
+;; text, set positive number. Otherwise, set negative number.
+;;
+;; Enjoy!
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'popwin)
+(require 'face-remap)
+
+;;; variables
+(defgroup guide-key nil
+ "Guide key bidings."
+ :group 'help
+ :prefix "guide-key/")
+
+(defcustom guide-key/guide-key-sequence nil
+ "*Key sequences to guide in `guide-key-mode'.
+This variable is a list of string representation.
+Both representations, like \"C-x r\" and \"\\C-xr\",
+are allowed.
+
+In addition, an element of this list can be a list whose car is
+the symbol for a certain mode, and whose cdr is a list of key
+sequences to consider only if that mode is active."
+ :type '(repeat (choice (string :tag "Prefix key sequence")
+ (cons :tag "Mode specific sequence"
+ (symbol :tag "Symbol for mode")
+ (repeat (string :tag "Prefix key sequence")))))
+ :group 'guide-key)
+
+(defcustom guide-key/polling-time 0.1
+ "*Polling time to check an input key sequence."
+ :type 'float
+ :group 'guide-key)
+
+(defcustom guide-key/idle-delay 1.0
+ "*Delay in seconds before guide buffer is displayed."
+ :type 'float
+ :group 'guide-key)
+
+(defcustom guide-key/highlight-prefix-regexp "prefix"
+ "*Regexp for prefix commands."
+ :type 'regexp
+ :group 'guide-key)
+
+(defcustom guide-key/highlight-command-regexp nil
+ "*Regexp for commands to highlight.
+If a command name matches this regexp, it is highlighted with
+`guide-key/highlight-command-face'.
+
+This variable can be a list and its element is either a regexp or
+a cons cell, its car is a regexp and its cdr is a face. If
+regexp, commands which match the regexp are highlighted with
+`guide-key/highlight-command-face'. If cons cell, commands
+which match the car regexp are highlighted with the cdr face."
+ :type '(choice (regexp :tag "Regexp to highlight")
+ (repeat (choice (regexp :tag "Regexp to highlight")
+ (cons (regexp :tag "Regexp to highlight")
+ (face :tag "Face on command")))))
+ :group 'guide-key)
+
+(defcustom guide-key/align-command-by-space-flag nil
+ "*If non-nil, align guide buffer by space."
+ :type 'boolean
+ :group 'guide-key)
+
+(defcustom guide-key/popup-window-position 'right
+ "*Position where guide buffer is popped up.
+This variable must be one of `right', `bottom', `left' and `top'."
+ :type '(radio (const right) (const bottom) (const left) (const top))
+ :group 'guide-key)
+
+(defcustom guide-key/text-scale-amount 0
+ "*Amount of scaling text in guide buffer.
+
+If positive number, the text becomes larger. If negative number,
+the text becomes smaller. Scale of the text is detemined by the
+value of variable `text-scale-mode-step'."
+ :type 'float
+ :group 'guide-key)
+
+(defcustom guide-key/recursive-key-sequence-flag nil
+ "*If non-nil, check an input key sequence recursively.
+For example, if `guide-key/guide-key-sequence' includes \"C-x\",
+guide buffer is popped up when you input \"C-x r\", \"C-x 4\" and
+any other prefixes following \"C-x\"."
+ :type 'boolean
+ :group 'guide-key)
+
+(defface guide-key/prefix-command-face
+ '((((class color) (background dark))
+ (:foreground "cyan"))
+ (((class color) (background light))
+ (:foreground "blue")))
+ "Face for prefix commands to highlight"
+ :group 'guide-key)
+
+(defface guide-key/highlight-command-face
+ '((((class color) (background dark))
+ (:foreground "yellow"))
+ (((class color) (background light))
+ (:foreground "orange red")))
+ "Face for commands to highlight"
+ :group 'guide-key)
+
+(defface guide-key/key-face
+ '((((class color) (background dark))
+ (:foreground "red"))
+ (((class color) (background light))
+ (:foreground "dark green")))
+ "Face for keys following to a key sequence"
+ :group 'guide-key)
+
+;;; internal variables
+(defvar guide-key/polling-timer nil
+ "Polling timer to check an input key sequence.")
+
+(defvar guide-key/idle-timer nil
+ "Idle timer to wait before popping up guide buffer.")
+
+(defvar guide-key/guide-buffer-name " *guide-key*"
+ "Buffer name of guide buffer.")
+
+(defvar guide-key/last-key-sequence-vector nil
+ "Key sequence input at the last polling operation.")
+
+;; or hook
+;; (add-hook 'pre-command-hook 'guide-key/hook-command)
+;; (setq pre-command-hook nil)
+;; (add-hook 'post-command-hook 'guide-key/key-event)
+;; (add-hook 'pre-command-hook 'show-this-command)
+
+;;; functions
+;;;###autoload
+(define-minor-mode guide-key-mode
+ "Toggle guide key mode.
+
+In guide key mode, Guide following keys to an input key sequence
+automatically and dynamically.
+With a prefix argument ARG, enable guide key mode if ARG is
+positive, otherwise disable."
+ :global t
+ :lighter " Guide"
+ (funcall (if guide-key-mode
+ 'guide-key/turn-on-timer
+ 'guide-key/turn-off-timer)))
+
+(defun guide-key/popup-function (&optional input)
+ "Popup function called after delay of `guide-key/idle-delay' second."
+ (let ((key-seq (or input (this-command-keys-vector)))
+ (regexp guide-key/highlight-command-regexp))
+ (let ((dsc-buf (current-buffer))
+ (max-width 0))
+ (with-current-buffer (get-buffer-create guide-key/guide-buffer-name)
+ (unless truncate-lines (setq truncate-lines t)) ; don't fold line
+ (when indent-tabs-mode (setq indent-tabs-mode nil)) ; don't use tab as white space
+ (setq mode-line-format nil)
+ (text-scale-set guide-key/text-scale-amount)
+ (erase-buffer)
+ (describe-buffer-bindings dsc-buf key-seq)
+ (when (> (guide-key/format-guide-buffer key-seq regexp) 0)
+ (guide-key/close-guide-buffer)
+ (guide-key/popup-guide-buffer))))))
+
+
+;;; internal functions
+(defun guide-key/polling-function ()
+ "Polling function executed every `guide-key/polling-time' second."
+ (let ((key-seq (this-command-keys-vector)))
+ (if (guide-key/popup-guide-buffer-p key-seq)
+ (when (guide-key/update-guide-buffer-p key-seq)
+ (guide-key/turn-on-idle-timer))
+ (guide-key/close-guide-buffer))
+ (setq guide-key/last-key-sequence-vector key-seq)))
+
+(defun guide-key/popup-guide-buffer ()
+ "Pop up guide buffer at `guide-key/popup-window-position'."
+ (let ((last-config popwin:popup-last-config))
+ (apply 'popwin:popup-buffer (get-buffer guide-key/guide-buffer-name)
+ :position guide-key/popup-window-position
+ :noselect t
+ (cond ((popwin:position-horizontal-p guide-key/popup-window-position)
+ `(:width ,(guide-key/popup-window-size 'horizontal)))
+ ((popwin:position-vertical-p guide-key/popup-window-position)
+ `(:height ,(guide-key/popup-window-size)))))
+ (setq popwin:popup-last-config last-config)))
+
+(defun guide-key/popup-window-size (&optional horizontal)
+ "Return an enough height or width of popup window to display
+all key bindings in guide buffer.
+
+If HORIZONTAL is omitted or nil, return the height of popup
+window. Otherwise, return the width of popup window"
+ (with-current-buffer (get-buffer guide-key/guide-buffer-name)
+ (let ((margin (if horizontal 5 1))
+ (scale (expt text-scale-mode-step text-scale-mode-amount)))
+ (if horizontal
+ (ceiling (* scale (+ (guide-key/buffer-max-width) margin)))
+ (ceiling (* scale (+ (count-lines (point-min) (point-max)) margin))))
+ )))
+
+(defun guide-key/close-guide-buffer ()
+ "Close guide buffer."
+ (when (eq popwin:popup-buffer (get-buffer guide-key/guide-buffer-name))
+ (popwin:close-popup-window))
+ (guide-key/turn-off-idle-timer)
+ )
+
+(add-hook 'pre-command-hook 'guide-key/close-guide-buffer)
+
+(defun guide-key/update-guide-buffer-p (key-seq)
+ "Return t if guide buffer should be updated."
+ (not (equal guide-key/last-key-sequence-vector key-seq)))
+
+(defun guide-key/popup-guide-buffer-p (key-seq)
+ "Return t if guide buffer should be popped up."
+ (and (> (length key-seq) 0)
+ (or (member key-seq (guide-key/buffer-key-seqences))
+ (and guide-key/recursive-key-sequence-flag
+ (guide-key/popup-guide-buffer-p (guide-key/vbutlast key-seq))))))
+
+(defun guide-key/buffer-key-seqences ()
+ "Return a list of key sequences (vector representation) in current buffer."
+ (let (lst)
+ ;; global key sequences
+ (dolist (ks guide-key/guide-key-sequence)
+ (when (stringp ks)
+ (setq lst (cons ks lst))))
+ ;; major-mode specific key sequences
+ (setq lst (append (assoc-default major-mode guide-key/guide-key-sequence) lst))
+ ;; minor-mode specific key sequences
+ (dolist (mmode minor-mode-list)
+ (when (and (boundp mmode) (symbol-value mmode))
+ (setq lst (append (assoc-default mmode guide-key/guide-key-sequence) lst))))
+ ;; convert key sequences to vector representation
+ (mapcar 'guide-key/convert-key-sequence-to-vector lst)))
+
+(defun guide-key/vbutlast (vec &optional n)
+ "Return a copy of vector VEC with the last N elements removed."
+ (vconcat (butlast (append vec nil) n)))
+
+(defun guide-key/convert-key-sequence-to-vector (key-seq)
+ "Convert key sequence KEY-SEQ to vector representation.
+For example, both \"C-x r\" and \"\\C-xr\" are converted to [24 114]"
+ (vconcat (read-kbd-macro key-seq)))
+
+(defun guide-key/turn-on-idle-timer ()
+ "Turn on an idle timer for popping up guide buffer."
+ (when (null guide-key/idle-timer)
+ (setq guide-key/idle-timer
+ (run-with-idle-timer guide-key/idle-delay t 'guide-key/popup-function))
+ ))
+
+(defun guide-key/turn-off-idle-timer ()
+ "Turn off the idle timer."
+ (when guide-key/idle-timer
+ (cancel-timer guide-key/idle-timer))
+ (setq guide-key/idle-timer nil))
+
+
+(defun guide-key/turn-on-timer ()
+ "Turn on a polling timer."
+ (when (null guide-key/polling-timer)
+ (setq guide-key/polling-timer
+ (run-at-time t guide-key/polling-time 'guide-key/polling-function))))
+
+(defun guide-key/turn-off-timer ()
+ "Turn off a polling timer."
+ (cancel-timer guide-key/polling-timer)
+ (setq guide-key/polling-timer nil))
+
+(defun guide-key/format-guide-buffer (key-seq &optional regexp)
+ "Format guide buffer. This function returns the number of following keys."
+ (let ((fkey-list nil) ; list of (following-key space command)
+ (fkey-str-list nil) ; fontified string of `fkey-list'
+ (fkey-list-len 0) ; length of above lists
+ (key-dsc (key-description key-seq)))
+ (untabify (point-min) (point-max)) ; replace tab to space
+ (goto-char (point-min))
+ ;; extract following keys from buffer bindings
+ (while (re-search-forward
+ (format "^%s \\([^ \t]+\\)\\([ \t]+\\)\\(\\(?:[^ \t\n]+ ?\\)+\\)$" (regexp-quote key-dsc)) nil t)
+ (add-to-list 'fkey-list
+ (list (match-string 1) (match-string 2) (match-string 3)) t))
+ (erase-buffer)
+ (when (> (setq fkey-list-len (length fkey-list)) 0)
+ ;; fontify following keys as string
+ (setq fkey-str-list
+ (loop for (key space command) in fkey-list
+ collect (guide-key/fontified-string key space command regexp)))
+ ;; insert a few following keys per line
+ (guide-key/insert-following-key fkey-str-list
+ (popwin:position-horizontal-p guide-key/popup-window-position))
+ (goto-char (point-min)))
+ fkey-list-len))
+
+(defun guide-key/insert-following-key (fkey-str-list horizontal)
+ "Insert a few following keys per line.
+
+If HORIZONTAL is omitted or nil, assume that guide buffer is
+popped up at top or bottom. Otherwise, assume that guide buffer
+is popped up at left or right."
+ (let* ((scale (expt text-scale-mode-step text-scale-mode-amount))
+ ;; Calculate the number of items per line
+ (columns
+ (if horizontal
+ (ceiling (/ (* (length fkey-str-list) scale)
+ (- (frame-height) (if tool-bar-mode 2 0) (if menu-bar-mode 1 0))))
+ (floor (/ (frame-width)
+ (* (apply 'max (mapcar 'length fkey-str-list)) scale))))))
+ ;; Insert following keys by columns per line.
+ (loop for fkey-str in fkey-str-list
+ for column from 1
+ do (insert fkey-str (if (= (mod column columns) 0) "\n" " ")))
+ (align-regexp (point-min) (point-max) "\\(\\s-*\\) \\[" 1 1 t)))
+
+(defun guide-key/fontified-string (key space command &optional regexp)
+ "Return fontified string of following key"
+ (let ((highlight-face (guide-key/get-highlight-face command regexp)))
+ (concat (propertize "[" 'face 'guide-key/key-face)
+ (if highlight-face (propertize key 'face highlight-face) key)
+ (propertize "]" 'face 'guide-key/key-face)
+ (if guide-key/align-command-by-space-flag space " ") ; white space
+ (if highlight-face (propertize command 'face highlight-face) command))))
+
+(defun guide-key/get-highlight-face (string &optional regexp)
+ "Return an appropriate face for highlighting STRING according
+to `guide-key/highlight-prefix-regexp' and
+`guide-key/highlight-command-regexp'. Return nil if an
+appropriate face is not found."
+ (let ((regexp (or regexp guide-key/highlight-command-regexp)))
+ ;; `guide-key/highlight-prefix-regexp' has the highest priority
+ (if (string-match guide-key/highlight-prefix-regexp string)
+ 'guide-key/prefix-command-face
+ ;; Else look up the first match in `guide-key/highlight-command-regexp'
+ (cond ((stringp regexp)
+ (when (string-match regexp string)
+ 'guide-key/highlight-command-face))
+ ((listp regexp)
+ (loop for elm in regexp
+ if (cond ((stringp elm)
+ (when (string-match elm string)
+ 'guide-key/highlight-command-face))
+ ((consp elm)
+ (when (string-match (car elm) string)
+ (cdr elm))))
+ return it)))
+ )))
+
+(defun guide-key/buffer-max-width ()
+ "Return max width in current buffer."
+ (let ((buf-str (buffer-substring-no-properties (point-min) (point-max))))
+ (apply 'max (mapcar 'length (split-string buf-str "\n")))))
+
+(defun guide-key/add-local-guide-key-sequence (key)
+ (add-to-list (make-local-variable 'guide-key/guide-key-sequence) key))
+
+(defun guide-key/add-local-highlight-command-regexp (regexp)
+ (make-local-variable 'guide-key/highlight-command-regexp)
+ (cond ((stringp guide-key/highlight-command-regexp)
+ (setq guide-key/highlight-command-regexp
+ (list regexp guide-key/highlight-command-regexp)))
+ ((listp guide-key/highlight-command-regexp)
+ (add-to-list 'guide-key/highlight-command-regexp regexp))))
+
+;;; key-chord hack
+(defadvice this-command-keys (after key-chord-hack disable)
+ "Add key chord to the key sequence returned by `this-command-keys'.
+
+Original `this-command-keys' returns \"[key-chord]\" when you
+type any of key chords, so it is difficult to know which key
+chord is pressed. This advice enables to distinguish pressed key
+chord."
+ (condition-case nil
+ (if (equal ad-return-value [key-chord])
+ (let ((rkeys (recent-keys)))
+ (setq ad-return-value
+ (vector 'key-chord (aref rkeys (- (length rkeys) 2))
+ (aref rkeys (- (length rkeys) 1))))))
+ (error "")))
+
+(defadvice this-command-keys-vector (after key-chord-hack disable)
+ "Add key chord to the key sequence returned by `this-command-keys-vector'.
+
+Original `this-command-keys-vector' returns \"[key-chord]\" when you
+type any of key chords, so it is difficult to know which key
+chord is pressed. This advice enables to distinguish pressed key
+chord."
+ (condition-case nil
+ (if (equal ad-return-value [key-chord])
+ (let ((rkeys (recent-keys)))
+ (setq ad-return-value
+ (vector 'key-chord (aref rkeys (- (length rkeys) 2))
+ (aref rkeys (- (length rkeys) 1))))))
+ (error [])))
+
+(defun guide-key/key-chord-hack-on ()
+ "Turn on key-chord hack of guide-key.
+
+This hack *may be dangerous* because it advices primitive
+functions; this-command-keys and this-command-keys-vector."
+ (interactive)
+ (dolist (fn '(this-command-keys this-command-keys-vector))
+ (ad-enable-advice fn 'after 'key-chord-hack)
+ (ad-activate fn))
+ (message "Turn on key-chord hack of guide-key"))
+
+(defun guide-key/key-chord-hack-off ()
+ "Turn off key-chord hack of guide-key."
+ (interactive)
+ (dolist (fn '(this-command-keys this-command-keys-vector))
+ (ad-disable-advice fn 'after 'key-chord-hack)
+ (ad-activate fn))
+ (message "Turn off key-chord hack of guide-key"))
+
+;;; debug
+(defun guide-key/message-events ()
+ ""
+ (message (format "lce:%S tck:%S tckv:%S lie:%S uce:%S"
+ last-command-event
+ (this-command-keys)
+ (this-command-keys-vector)
+ last-input-event
+ unread-command-events
+ )))
+;; (setq ttt (run-at-time t 1 'guide-key/message-events))
+;; (cancel-timer ttt)
+
+(provide 'guide-key)
+;;; guide-key.el ends here
--- /dev/null
+;;; popwin.el --- Popup Window Manager.
+
+;; Copyright (C) 2011, 2012, 2013, 2014 Tomohiro Matsuyama
+
+;; Author: Tomohiro Matsuyama <tomoNOSPAMcx4a.org>
+;; Keywords: convenience
+;; Version: 20140902.1727
+;; X-Original-Version: 0.7.0alpha
+
+;; This program 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 of the License, 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Popwin makes you free from the hell of annoying buffers such like
+;; *Help*, *Completions*, *compilation*, and etc.
+;;
+;; To use popwin, just add the following code into your .emacs:
+;;
+;; (require 'popwin)
+;; (popwin-mode 1)
+;;
+;; Then try to show some buffer, for example *Help* or
+;; *Completeions*. Unlike standard behavior, their buffers may be
+;; shown in a popup window at the bottom of the frame. And you can
+;; close the popup window seamlessly by typing C-g or selecting other
+;; windows.
+;;
+;; `popwin:display-buffer' displays special buffers in a popup window
+;; and displays normal buffers as unsual. Special buffers are
+;; specified in `popwin:special-display-config', which tells popwin
+;; how to display such buffers. See docstring of
+;; `popwin:special-display-config' for more information.
+;;
+;; The default width/height/position of popup window can be changed by
+;; setting `popwin:popup-window-width', `popwin:popup-window-height',
+;; and `popwin:popup-window-position'. You can also change the
+;; behavior for a specific buffer. See docstring of
+;; `popwin:special-display-config'.
+;;
+;; If you want to use some useful commands such like
+;; `popwin:popup-buffer' and `popwin:find-file' easily. you may bind
+;; `popwin:keymap' to `C-z', for example, like:
+;;
+;; (global-set-key (kbd "C-z") popwin:keymap)
+;;
+;; See also `popwin:keymap' documentation.
+;;
+;; Enjoy!
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defconst popwin:version "0.7.0alpha")
+
+\f
+
+;;; Utility
+
+(defun popwin:listify (object)
+ "Return a singleton list of OBJECT if OBJECT is an atom,
+otherwise OBJECT itself."
+ (if (atom object) (list object) object))
+
+(defun popwin:subsitute-in-tree (map tree)
+ (if (consp tree)
+ (cons (popwin:subsitute-in-tree map (car tree))
+ (popwin:subsitute-in-tree map (cdr tree)))
+ (or (cdr (assq tree map)) tree)))
+
+(defun popwin:get-buffer (buffer-or-name &optional if-not-found)
+ "Return a buffer named BUFFER-OR-NAME or BUFFER-OR-NAME itself
+if BUFFER-OR-NAME is a buffer. If BUFFER-OR-NAME is a string and
+such a buffer named BUFFER-OR-NAME not found, a new buffer will
+be returned when IF-NOT-FOUND is :create, or an error reported
+when IF-NOT-FOUND is :error. The default of value of IF-NOT-FOUND
+is :error."
+ (ecase (or if-not-found :error)
+ (:create
+ (get-buffer-create buffer-or-name))
+ (:error
+ (or (get-buffer buffer-or-name)
+ (error "No buffer named %s" buffer-or-name)))))
+
+(defun popwin:switch-to-buffer (buffer-or-name &optional norecord)
+ "Call `switch-to-buffer' forcing BUFFER-OF-NAME be displayed in
+the selected window."
+ (with-no-warnings
+ (if (>= emacs-major-version 24)
+ (switch-to-buffer buffer-or-name norecord t)
+ (switch-to-buffer buffer-or-name norecord))))
+
+(defun popwin:buried-buffer-p (buffer)
+ "Return t if BUFFER might be thought of as a buried buffer."
+ (eq (car (last (buffer-list))) buffer))
+
+(defun popwin:window-point (window)
+ "Return window-point of WINDOW. If WINDOW is currently
+selected, then return buffer-point instead."
+ (if (eq (selected-window) window)
+ (with-current-buffer (window-buffer window)
+ (point))
+ (window-point window)))
+
+(defun popwin:window-deletable-p (window)
+ "Return t if WINDOW is deletable, meaning that WINDOW is alive
+and not a minibuffer's window, plus there is two or more windows."
+ (and (window-live-p window)
+ (not (window-minibuffer-p window))
+ (not (one-window-p))))
+
+(defmacro popwin:save-selected-window (&rest body)
+ "Evaluate BODY saving the selected window."
+ `(with-selected-window (selected-window) ,@body))
+
+(defun popwin:minibuffer-window-selected-p ()
+ "Return t if minibuffer window is selected."
+ (minibuffer-window-active-p (selected-window)))
+
+(defun popwin:last-selected-window ()
+ "Return currently selected window or lastly selected window if
+minibuffer window is selected."
+ (if (popwin:minibuffer-window-selected-p)
+ (minibuffer-selected-window)
+ (selected-window)))
+
+\f
+
+;;; Common
+
+(defvar popwin:debug nil)
+
+(defvar popwin:dummy-buffer nil)
+
+(defun popwin:dummy-buffer ()
+ (if (buffer-live-p popwin:dummy-buffer)
+ popwin:dummy-buffer
+ (setq popwin:dummy-buffer (get-buffer-create " *popwin-dummy*"))))
+
+(defun popwin:kill-dummy-buffer ()
+ (when (buffer-live-p popwin:dummy-buffer)
+ (kill-buffer popwin:dummy-buffer))
+ (setq popwin:dummy-buffer nil))
+
+(defun popwin:window-trailing-edge-adjustable-p (window)
+ "Return t if a trailing edge of WINDOW is adjustable."
+ (let ((next-window (next-window window)))
+ (and (not (eq next-window (frame-first-window)))
+ (not (eq (window-buffer next-window)
+ (popwin:dummy-buffer))))))
+
+(defun* popwin:adjust-window-edges (window
+ edges
+ &optional
+ (hfactor 1)
+ (vfactor 1))
+ "Adjust edges of WINDOW to EDGES accoring to horizontal factor
+HFACTOR, and vertical factor VFACTOR."
+ (when (popwin:window-trailing-edge-adjustable-p window)
+ (destructuring-bind ((left top right bottom)
+ (cur-left cur-top cur-right cur-bottom))
+ (list edges (window-edges window))
+ (let ((hdelta (floor (- (* (- right left) hfactor) (- cur-right cur-left))))
+ (vdelta (floor (- (* (- bottom top) vfactor) (- cur-bottom cur-top)))))
+ (ignore-errors
+ (adjust-window-trailing-edge window hdelta t))
+ (ignore-errors
+ (adjust-window-trailing-edge window vdelta nil))))))
+
+(defun popwin:window-config-tree-1 (node)
+ (if (windowp node)
+ (list 'window
+ node
+ (window-buffer node)
+ (popwin:window-point node)
+ (window-start node)
+ (window-edges node)
+ (eq (selected-window) node)
+ (window-dedicated-p node))
+ (destructuring-bind (dir edges . windows) node
+ (append (list dir edges)
+ (mapcar 'popwin:window-config-tree-1 windows)))))
+
+(defun popwin:window-config-tree ()
+ "Return `window-tree' with replacing window values in the tree
+with persistent representations."
+ (destructuring-bind (root mini)
+ (window-tree)
+ (list (popwin:window-config-tree-1 root) mini)))
+
+(defun popwin:replicate-window-config (window node hfactor vfactor)
+ "Replicate NODE of window configuration on WINDOW with
+horizontal factor HFACTOR, and vertical factor VFACTOR. The
+return value is a association list of mapping from old-window to
+new-window."
+ (if (eq (car node) 'window)
+ (destructuring-bind (old-win buffer point start edges selected dedicated)
+ (cdr node)
+ (set-window-dedicated-p window nil)
+ (popwin:adjust-window-edges window edges hfactor vfactor)
+ (with-selected-window window
+ (popwin:switch-to-buffer buffer t))
+ (when selected
+ (select-window window))
+ (set-window-point window point)
+ (set-window-start window start t)
+ (when dedicated
+ (set-window-dedicated-p window t))
+ `((,old-win . ,window)))
+ (destructuring-bind (dir edges . windows) node
+ (loop while windows
+ for sub-node = (pop windows)
+ for win = window then next-win
+ for next-win = (and windows (split-window win nil (not dir)))
+ append (popwin:replicate-window-config win sub-node hfactor vfactor)))))
+
+(defun popwin:restore-window-outline (node outline)
+ "Restore window outline accoding to the structures of NODE
+which is a node of `window-tree' and OUTLINE which is a node of
+`popwin:window-config-tree'."
+ (cond
+ ((and (windowp node)
+ (eq (car outline) 'window))
+ ;; same window
+ (destructuring-bind (old-win buffer point start edges selected dedicated)
+ (cdr outline)
+ (popwin:adjust-window-edges node edges)
+ (when (and (eq (window-buffer node) buffer)
+ (eq (popwin:window-point node) point))
+ (set-window-start node start))))
+ ((or (windowp node)
+ (not (eq (car node) (car outline))))
+ ;; different structure
+ ;; nothing to do
+ )
+ (t
+ (let ((child-nodes (cddr node))
+ (child-outlines (cddr outline)))
+ (when (eq (length child-nodes) (length child-outlines))
+ ;; same structure
+ (loop for child-node in child-nodes
+ for child-outline in child-outlines
+ do (popwin:restore-window-outline child-node child-outline)))))))
+
+(defun popwin:position-horizontal-p (position)
+ "Return t if POSITION is hozirontal."
+ (and (memq position '(left :left right :right)) t))
+
+(defun popwin:position-vertical-p (position)
+ "Return t if POSITION is vertical."
+ (and (memq position '(top :top bottom :bottom)) t))
+
+(defun popwin:create-popup-window-1 (window size position)
+ "Create a new window with SIZE at POSITION of WINDOW. The
+return value is a list of a master window and the popup window."
+ (let ((width (window-width window))
+ (height (window-height window)))
+ (ecase position
+ ((left :left)
+ (list (split-window window size t)
+ window))
+ ((top :top)
+ (list (split-window window size nil)
+ window))
+ ((right :right)
+ (list window
+ (split-window window (- width size) t)))
+ ((bottom :bottom)
+ (list window
+ (split-window window (- height size) nil))))))
+
+(defun* popwin:create-popup-window (&optional (size 15) (position 'bottom) (adjust t))
+ "Create a popup window with SIZE on the frame. If SIZE
+is integer, the size of the popup window will be SIZE. If SIZE is
+float, the size of popup window will be a multiplier of SIZE and
+frame-size. can be an integer and a float. If ADJUST is t, all of
+windows will be adjusted to fit the frame. POSITION must be one
+of (left top right bottom). The return value is a pair of a
+master window and the popup window. To close the popup window
+properly, get `current-window-configuration' before calling this
+function, and call `set-window-configuration' with the
+window-configuration."
+ (let* ((root (car (popwin:window-config-tree)))
+ (root-win (popwin:last-selected-window))
+ (hfactor 1)
+ (vfactor 1))
+ (popwin:save-selected-window
+ (delete-other-windows root-win))
+ (let ((root-width (window-width root-win))
+ (root-height (window-height root-win)))
+ (when adjust
+ (if (floatp size)
+ (if (popwin:position-horizontal-p position)
+ (setq hfactor (- 1.0 size)
+ size (round (* root-width size)))
+ (setq vfactor (- 1.0 size)
+ size (round (* root-height size))))
+ (if (popwin:position-horizontal-p position)
+ (setq hfactor (/ (float (- root-width size)) root-width))
+ (setq vfactor (/ (float (- root-height size)) root-height)))))
+ (destructuring-bind (master-win popup-win)
+ (popwin:create-popup-window-1 root-win size position)
+ ;; Mark popup-win being a popup window.
+ (with-selected-window popup-win
+ (popwin:switch-to-buffer (popwin:dummy-buffer) t))
+ (let ((win-map (popwin:replicate-window-config master-win root hfactor vfactor)))
+ (list master-win popup-win win-map))))))
+
+\f
+
+;;; Common User Interface
+
+(defgroup popwin nil
+ "Popup Window Manager."
+ :group 'convenience
+ :prefix "popwin:")
+
+(defcustom popwin:popup-window-position 'bottom
+ "Default popup window position. This must be one of (left top right
+bottom)."
+ :type 'symbol
+ :group 'popwin)
+
+(defcustom popwin:popup-window-width 30
+ "Default popup window width. If `popwin:popup-window-position'
+is top or bottom, this configuration will be ignored. If this
+variable is float, the popup window width will be a multiplier of
+the value and frame-size."
+ :type 'number
+ :group 'popwin)
+
+(defcustom popwin:popup-window-height 15
+ "Default popup window height. If `popwin:popup-window-position'
+is left or right, this configuration will be ignored. If this
+variable is float, the popup window height will be a multiplier
+of the value and frame-size."
+ :type 'number
+ :group 'popwin)
+
+(defcustom popwin:reuse-window 'current
+ "Non-nil means `popwin:display-buffer' will not popup the
+visible buffer. The value is same as a second argument of
+`get-buffer-window', except `current' means the selected frame."
+ :group 'popwin)
+
+(defcustom popwin:adjust-other-windows t
+ "Non-nil means all of other windows will be adjusted to fit the
+frame when a popup window is shown."
+ :type 'boolean
+ :group 'popwin)
+
+(defvar popwin:context-stack nil)
+
+(defvar popwin:popup-window nil
+ "Main popup window instance.")
+
+(defvar popwin:popup-buffer nil
+ "Buffer of currently shown in the popup window.")
+
+(defvar popwin:popup-last-config nil
+ "Arguments to `popwin:popup-buffer' of last call.")
+
+;; Deprecated
+(defvar popwin:master-window nil
+ "Master window of a popup window.")
+
+(defvar popwin:focus-window nil
+ "Focused window which is used to check whether or not to close
+the popup window.")
+
+(defvar popwin:selected-window nil
+ "Last selected window when the popup window is shown.")
+
+(defvar popwin:popup-window-dedicated-p nil
+ "Non-nil means the popup window is dedicated to the original
+popup buffer.")
+
+(defvar popwin:popup-window-stuck-p nil
+ "Non-nil means the popup window has been stuck.")
+
+(defvar popwin:window-outline nil
+ "Original window outline which is obtained by
+`popwin:window-config-tree'.")
+
+(defvar popwin:window-map nil
+ "Mapping from old windows to new windows.")
+
+(defvar popwin:window-config nil
+ "An original window configuration for restoreing.")
+
+(defvar popwin:close-popup-window-timer nil
+ "Timer of closing the popup window.")
+
+(defvar popwin:close-popup-window-timer-interval 0.05
+ "Interval of `popwin:close-popup-window-timer'.")
+
+(defvar popwin:before-popup-hook nil)
+
+(defvar popwin:after-popup-hook nil)
+
+(symbol-macrolet ((context-vars '(popwin:popup-window
+ popwin:popup-buffer
+ popwin:master-window
+ popwin:focus-window
+ popwin:selected-window
+ popwin:popup-window-dedicated-p
+ popwin:popup-window-stuck-p
+ popwin:window-outline
+ popwin:window-map)))
+ (defun popwin:valid-context-p (context)
+ (window-live-p (plist-get context 'popwin:popup-window)))
+
+ (defun popwin:current-context ()
+ (loop for var in context-vars
+ collect var
+ collect (symbol-value var)))
+
+ (defun popwin:use-context (context)
+ (loop for var = (pop context)
+ for val = (pop context)
+ while var
+ do (set var val)))
+
+ (defun popwin:push-context ()
+ (push (popwin:current-context) popwin:context-stack))
+
+ (defun popwin:pop-context ()
+ (popwin:use-context (pop popwin:context-stack)))
+
+ (defun* popwin:find-context-for-buffer (buffer &key valid-only)
+ (loop with stack = popwin:context-stack
+ for context = (pop stack)
+ while context
+ if (and (eq buffer (plist-get context 'popwin:popup-buffer))
+ (or (not valid-only)
+ (popwin:valid-context-p context)))
+ return (list context stack))))
+
+(defun popwin:popup-window-live-p ()
+ "Return t if `popwin:popup-window' is alive."
+ (window-live-p popwin:popup-window))
+
+(defun* popwin:update-window-reference (symbol
+ &key
+ (map popwin:window-map)
+ safe
+ recursive)
+ (unless (and safe (not (boundp symbol)))
+ (let ((value (symbol-value symbol)))
+ (set symbol
+ (if recursive
+ (popwin:subsitute-in-tree map value)
+ (or (cdr (assq value map)) value))))))
+
+(defun popwin:start-close-popup-window-timer ()
+ (or popwin:close-popup-window-timer
+ (setq popwin:close-popup-window-timer
+ (run-with-idle-timer popwin:close-popup-window-timer-interval
+ popwin:close-popup-window-timer-interval
+ 'popwin:close-popup-window-timer))))
+
+(defun popwin:stop-close-popup-window-timer ()
+ (when popwin:close-popup-window-timer
+ (cancel-timer popwin:close-popup-window-timer)
+ (setq popwin:close-popup-window-timer nil)))
+
+(defun popwin:close-popup-window-timer ()
+ (condition-case var
+ (popwin:close-popup-window-if-necessary)
+ (error
+ (message "popwin:close-popup-window-timer: error: %s" var)
+ (when popwin:debug (backtrace)))))
+
+(defun popwin:close-popup-window (&optional keep-selected)
+ "Close the popup window and restore to the previous window
+configuration. If KEEP-SELECTED is non-nil, the lastly selected
+window will not be selected."
+ (interactive)
+ (when popwin:popup-window
+ (unwind-protect
+ (progn
+ (when (popwin:window-deletable-p popwin:popup-window)
+ (delete-window popwin:popup-window))
+ (popwin:restore-window-outline (car (window-tree)) popwin:window-outline)
+ ;; Call `redisplay' here so `window-start' could be set
+ ;; prior to the point change of the master buffer.
+ (redisplay)
+ (when (and (not keep-selected)
+ (window-live-p popwin:selected-window))
+ (select-window popwin:selected-window)))
+ (popwin:pop-context)
+ ;; Cleanup if no context left.
+ (when (null popwin:context-stack)
+ (popwin:kill-dummy-buffer)
+ (popwin:stop-close-popup-window-timer)))))
+
+(defun popwin:close-popup-window-if-necessary ()
+ "Close the popup window if necessary. The all situations where
+the popup window will be closed are followings:
+
+* `C-g' has been pressed.
+* The popup buffer has been killed.
+* The popup buffer has been buried.
+* The popup buffer has been changed if the popup window is
+ dedicated to the buffer.
+* Another window has been selected."
+ (when popwin:popup-window
+ (let* ((window (selected-window))
+ (window-point (popwin:window-point window))
+ (window-buffer (window-buffer window))
+ (minibuf-window-p (window-minibuffer-p window))
+ (reading-from-minibuf
+ (and minibuf-window-p
+ (minibuffer-prompt)
+ t))
+ (quit-requested
+ (and (eq last-command 'keyboard-quit)
+ (eq last-command-event ?\C-g)))
+ (other-window-selected
+ (and (not (eq window popwin:focus-window))
+ (not (eq window popwin:popup-window))))
+ (orig-this-command this-command)
+ (popup-buffer-alive
+ (buffer-live-p popwin:popup-buffer))
+ (popup-buffer-buried
+ (popwin:buried-buffer-p popwin:popup-buffer))
+ (popup-buffer-changed-despite-of-dedicated
+ (and popwin:popup-window-dedicated-p
+ (not popwin:popup-window-stuck-p)
+ (or (not other-window-selected)
+ (not reading-from-minibuf))
+ (buffer-live-p window-buffer)
+ (not (eq popwin:popup-buffer window-buffer))))
+ (popup-window-alive (popwin:popup-window-live-p)))
+ (when (or quit-requested
+ (not popup-buffer-alive)
+ popup-buffer-buried
+ popup-buffer-changed-despite-of-dedicated
+ (not popup-window-alive)
+ (and other-window-selected
+ (not minibuf-window-p)
+ (not popwin:popup-window-stuck-p)))
+ (when popwin:debug
+ (message (concat "popwin: CLOSE:\n"
+ " quit-requested = %s\n"
+ " popup-buffer-alive = %s\n"
+ " popup-buffer-buried = %s\n"
+ " popup-buffer-changed-despite-of-dedicated = %s\n"
+ " popup-window-alive = %s\n"
+ " (selected-window) = %s\n"
+ " popwin:focus-window = %s\n"
+ " popwin:popup-window = %s\n"
+ " other-window-selected = %s\n"
+ " minibuf-window-p = %s\n"
+ " popwin:popup-window-stuck-p = %s")
+ quit-requested
+ popup-buffer-alive
+ popup-buffer-buried
+ popup-buffer-changed-despite-of-dedicated
+ popup-window-alive
+ window
+ popwin:focus-window
+ popwin:popup-window
+ other-window-selected
+ minibuf-window-p
+ popwin:popup-window-stuck-p))
+ (when (and quit-requested
+ (null orig-this-command))
+ (setq this-command 'popwin:close-popup-window)
+ (run-hooks 'pre-command-hook))
+ (cond
+ ((and quit-requested
+ (null orig-this-command)
+ popwin:window-config)
+ (set-window-configuration popwin:window-config)
+ (setq popwin:window-config nil))
+ (reading-from-minibuf
+ (popwin:close-popup-window)
+ (select-window (minibuffer-window)))
+ (t
+ (popwin:close-popup-window
+ (and other-window-selected
+ (and popup-buffer-alive
+ (not popup-buffer-buried))))
+ (when popup-buffer-changed-despite-of-dedicated
+ (popwin:switch-to-buffer window-buffer)
+ (goto-char window-point))))
+ (when (and quit-requested
+ (null orig-this-command))
+ (run-hooks 'post-command-hook)
+ (setq last-command 'popwin:close-popup-window))))))
+
+;;;###autoload
+(defun* popwin:popup-buffer (buffer
+ &key
+ (width popwin:popup-window-width)
+ (height popwin:popup-window-height)
+ (position popwin:popup-window-position)
+ noselect
+ dedicated
+ stick
+ tail)
+ "Show BUFFER in a popup window and return the popup window. If
+NOSELECT is non-nil, the popup window will not be selected. If
+STICK is non-nil, the popup window will be stuck. If TAIL is
+non-nil, the popup window will show the last contents. Calling
+`popwin:popup-buffer' during `popwin:popup-buffer' is allowed. In
+that case, the buffer of the popup window will be replaced with
+BUFFER."
+ (interactive "BPopup buffer:\n")
+ (setq buffer (get-buffer buffer))
+ (popwin:push-context)
+ (run-hooks 'popwin:before-popup-hook)
+ (multiple-value-bind (context context-stack)
+ (popwin:find-context-for-buffer buffer :valid-only t)
+ (if context
+ (progn
+ (popwin:use-context context)
+ (setq popwin:context-stack context-stack))
+ (let ((win-outline (car (popwin:window-config-tree))))
+ (destructuring-bind (master-win popup-win win-map)
+ (let ((size (if (popwin:position-horizontal-p position) width height))
+ (adjust popwin:adjust-other-windows))
+ (popwin:create-popup-window size position adjust))
+ (setq popwin:popup-window popup-win
+ popwin:master-window master-win
+ popwin:window-outline win-outline
+ popwin:window-map win-map
+ popwin:window-config nil
+ popwin:selected-window (selected-window)))
+ (popwin:update-window-reference 'popwin:context-stack :recursive t)
+ (popwin:start-close-popup-window-timer))
+ (with-selected-window popwin:popup-window
+ (popwin:switch-to-buffer buffer)
+ (when tail
+ (set-window-point popwin:popup-window (point-max))
+ (recenter -2)))
+ (setq popwin:popup-buffer buffer
+ popwin:popup-last-config (list buffer
+ :width width :height height :position position
+ :noselect noselect :dedicated dedicated
+ :stick stick :tail tail)
+ popwin:popup-window-dedicated-p dedicated
+ popwin:popup-window-stuck-p stick)))
+ (if noselect
+ (setq popwin:focus-window popwin:selected-window)
+ (setq popwin:focus-window popwin:popup-window)
+ (select-window popwin:popup-window))
+ (run-hooks 'popwin:after-popup-hook)
+ popwin:popup-window)
+
+(defun popwin:popup-last-buffer (&optional noselect)
+ "Show the last popup buffer with the same configuration. If
+NOSELECT is non-nil, the popup window will not be selected."
+ (interactive "P")
+ (if popwin:popup-last-config
+ (if noselect
+ (destructuring-bind (buffer . keyargs) popwin:popup-last-config
+ (apply 'popwin:popup-buffer buffer :noselect t keyargs))
+ (apply 'popwin:popup-buffer popwin:popup-last-config))
+ (error "No popup buffer ever")))
+(defalias 'popwin:display-last-buffer 'popwin:popup-last-buffer)
+
+(defun popwin:select-popup-window ()
+ "Select the currently shown popup window."
+ (interactive)
+ (if (popwin:popup-window-live-p)
+ (select-window popwin:popup-window)
+ (error "No popup window displayed")))
+
+(defun popwin:stick-popup-window ()
+ "Stick the currently shown popup window. The popup window can
+be closed by `popwin:close-popup-window'."
+ (interactive)
+ (if (popwin:popup-window-live-p)
+ (progn
+ (setq popwin:popup-window-stuck-p t)
+ (message "Popup window stuck"))
+ (error "No popup window displayed")))
+
+\f
+
+;;; Special Display
+
+(defmacro popwin:without-special-displaying (&rest body)
+ "Evaluate BODY without special displaying."
+ (if (boundp 'display-buffer-alist)
+ `(with-no-warnings
+ (let ((display-buffer-function nil)
+ (display-buffer-alist
+ (remove '(popwin:display-buffer-condition
+ popwin:display-buffer-action)
+ display-buffer-alist)))
+ ,@body))
+ `(with-no-warnings (let ((display-buffer-function nil)) ,@body))))
+
+(defcustom popwin:special-display-config
+ '(;; Emacs
+ ("*Miniedit Help*" :noselect t)
+ help-mode
+ (completion-list-mode :noselect t)
+ (compilation-mode :noselect t)
+ (grep-mode :noselect t)
+ (occur-mode :noselect t)
+ ("*Pp Macroexpand Output*" :noselect t)
+ "*Shell Command Output*"
+ ;; VC
+ "*vc-diff*"
+ "*vc-change-log*"
+ ;; Undo-Tree
+ (" *undo-tree*" :width 60 :position right)
+ ;; Anything
+ ("^\\*anything.*\\*$" :regexp t)
+ ;; SLIME
+ "*slime-apropos*"
+ "*slime-macroexpansion*"
+ "*slime-description*"
+ ("*slime-compilation*" :noselect t)
+ "*slime-xref*"
+ (sldb-mode :stick t)
+ slime-repl-mode
+ slime-connection-list-mode)
+ "Configuration of special displaying buffer for
+`popwin:display-buffer' and
+`popwin:special-display-popup-window'. The value is a list of
+CONFIG as a form of (PATTERN . KEYWORDS) where PATTERN is a
+pattern of specifying buffer and KEYWORDS is a list of a pair of
+key and value. PATTERN is in general a buffer name, a symbol
+specifying major-mode of buffer, or a predicate function which
+takes one argument: the buffer. If CONFIG is a string or a
+symbol, PATTERN will be CONFIG and KEYWORDS will be
+empty. Available keywords are following:
+
+ regexp: If the value is non-nil, PATTERN will be used as regexp
+ to matching buffer.
+
+ width, height: Specify width or height of the popup window. If
+ no size specified, `popwin:popup-window-width' or
+ `popwin:popup-window-height' will be used. See also position
+ keyword.
+
+ position: The value must be one of (left top right bottom). The
+ popup window will shown at the position of the frame. If no
+ position specified, `popwin:popup-window-position' will be
+ used.
+
+ noselect: If the value is non-nil, the popup window will not be
+ selected when it is shown.
+
+ dedicated: If the value is non-nil, the popup window will be
+ dedicated to the original popup buffer. In this case, when
+ another buffer is selected in the popup window, the popup
+ window will be closed immedicately and the selected buffer
+ will be shown on the previously selected window.
+
+ stick: If the value is non-nil, the popup window will be stuck
+ when it is shown.
+
+ tail: If the value is non-nil, the popup window will show the
+ last contents.
+
+Examples: With '(\"*scratch*\" :height 30 :position top),
+*scratch* buffer will be shown at the top of the frame with
+height 30. With '(dired-mode :width 80 :position left), dired
+buffers will be shown at the left of the frame with width 80."
+ :type '(repeat
+ (cons :tag "Config"
+ (choice :tag "Pattern"
+ (string :tag "Buffer Name")
+ (symbol :tag "Major Mode"))
+ (plist :tag "Keywords"
+ :value (:regexp nil) ; BUG? need default value
+ :options
+ ((:regexp (boolean :tag "On/Off"))
+ (:width (choice :tag "Width"
+ (integer :tag "Width")
+ (float :tag "Width (%)")))
+ (:height (choice :tag "Height"
+ (integer :tag "Height")
+ (float :tag "Height (%)")))
+ (:position (choice :tag "Position"
+ (const :tag "Bottom" bottom)
+ (const :tag "Top" top)
+ (const :tag "Left" left)
+ (const :tag "Right" right)))
+ (:noselect (boolean :tag "On/Off"))
+ (:dedicated (boolean :tag "On/Off"))
+ (:stick (boolean :tag "On/Off"))
+ (:tail (boolean :tag "On/Off"))))))
+ :get (lambda (symbol)
+ (mapcar (lambda (element)
+ (if (consp element)
+ element
+ (list element)))
+ (default-value symbol)))
+ :group 'popwin)
+
+(defun popwin:apply-display-buffer (function buffer &optional not-this-window)
+ "Call FUNCTION on BUFFER without special displaying."
+ (popwin:without-special-displaying
+ (let ((same-window
+ (or (same-window-p (buffer-name buffer))
+ (and (>= emacs-major-version 24)
+ (boundp 'action)
+ (consp action)
+ (eq (car action) 'display-buffer-same-window)))))
+ ;; Close the popup window here so that the popup window won't to
+ ;; be splitted.
+ (when (and (eq (selected-window) popwin:popup-window)
+ (not same-window))
+ (popwin:close-popup-window)))
+ (if (and (>= emacs-major-version 24)
+ (boundp 'action)
+ (boundp 'frame))
+ ;; Use variables ACTION and FRAME which are formal parameters
+ ;; of DISPLAY-BUFFER.
+ ;;
+ ;; TODO use display-buffer-alist instead of
+ ;; display-buffer-function.
+ (funcall function buffer action frame)
+ (funcall function buffer not-this-window))))
+
+(defun popwin:original-display-buffer (buffer &optional not-this-window)
+ "Call `display-buffer' on BUFFER without special displaying."
+ (popwin:apply-display-buffer 'display-buffer buffer not-this-window))
+
+(defun popwin:original-pop-to-buffer (buffer &optional not-this-window)
+ "Call `pop-to-buffer' on BUFFER without special displaying."
+ (popwin:apply-display-buffer 'pop-to-buffer buffer not-this-window))
+
+(defun popwin:original-display-last-buffer ()
+ "Call `display-buffer' for the last popup buffer without
+special displaying."
+ (interactive)
+ (if popwin:popup-last-config
+ (popwin:original-display-buffer (car popwin:popup-last-config))
+ (error "No popup buffer ever")))
+
+(defun popwin:switch-to-last-buffer ()
+ "Switch to the last popup buffer."
+ (interactive)
+ (if popwin:popup-last-config
+ (popwin:apply-display-buffer
+ (lambda (buffer &rest ignore) (switch-to-buffer buffer))
+ (car popwin:popup-last-config))
+ (error "No popup buffer ever")))
+
+(defun popwin:original-pop-to-last-buffer ()
+ "Call `pop-to-buffer' for the last popup buffer without
+special displaying."
+ (interactive)
+ (if popwin:popup-last-config
+ (popwin:original-pop-to-buffer (car popwin:popup-last-config))
+ (error "No popup buffer ever")))
+
+(defun popwin:reuse-window-p (buffer-or-name not-this-window)
+ "Return t if a window showing BUFFER-OR-NAME exists and should
+be used displaying the buffer."
+ (and popwin:reuse-window
+ (let ((window (get-buffer-window buffer-or-name
+ (if (eq popwin:reuse-window 'current)
+ nil
+ popwin:reuse-window))))
+ (and (not (null window))
+ (not (eq window (if not-this-window (selected-window))))))))
+
+(defun* popwin:match-config (buffer)
+ (when (stringp buffer) (setq buffer (get-buffer buffer)))
+ (loop with name = (buffer-name buffer)
+ with mode = (buffer-local-value 'major-mode buffer)
+ for config in popwin:special-display-config
+ for (pattern . keywords) = (popwin:listify config)
+ if (cond ((eq pattern t) t)
+ ((and (stringp pattern) (plist-get keywords :regexp))
+ (string-match pattern name))
+ ((stringp pattern)
+ (string= pattern name))
+ ((symbolp pattern)
+ (eq pattern mode))
+ ((functionp pattern)
+ (funcall pattern buffer))
+ (t (error "Invalid pattern: %s" pattern)))
+ return (cons pattern keywords)))
+
+(defun* popwin:display-buffer-1 (buffer-or-name
+ &key
+ default-config-keywords
+ (if-buffer-not-found :create)
+ if-config-not-found)
+ "Display BUFFER-OR-NAME, if possible, in a popup
+window. Otherwise call IF-CONFIG-NOT-FOUND with BUFFER-OR-NAME if
+the value is a function. If IF-CONFIG-NOT-FOUND is nil,
+`popwin:popup-buffer' will be called. IF-BUFFER-NOT-FOUND
+indicates what happens when there is no such buffers. If the
+value is :create, create a new buffer named BUFFER-OR-NAME. If
+the value is :error, report an error. The default value
+is :create. DEFAULT-CONFIG-KEYWORDS is a property list which
+specifies default values of the config."
+ (let* ((buffer (popwin:get-buffer buffer-or-name if-buffer-not-found))
+ (pattern-and-keywords (popwin:match-config buffer)))
+ (unless pattern-and-keywords
+ (if if-config-not-found
+ (return-from popwin:display-buffer-1
+ (funcall if-config-not-found buffer))
+ (setq pattern-and-keywords '(t))))
+ (destructuring-bind (&key regexp width height position noselect dedicated stick tail)
+ (append (cdr pattern-and-keywords) default-config-keywords)
+ (popwin:popup-buffer buffer
+ :width (or width popwin:popup-window-width)
+ :height (or height popwin:popup-window-height)
+ :position (or position popwin:popup-window-position)
+ :noselect (or (popwin:minibuffer-window-selected-p) noselect)
+ :dedicated dedicated
+ :stick stick
+ :tail tail))))
+
+;;;###autoload
+(defun popwin:display-buffer (buffer-or-name &optional not-this-window)
+ "Display BUFFER-OR-NAME, if possible, in a popup window, or as
+usual. This function can be used as a value of
+`display-buffer-function'."
+ (interactive "BDisplay buffer:\n")
+ (if (popwin:reuse-window-p buffer-or-name not-this-window)
+ ;; Call `display-buffer' for reuse.
+ (popwin:original-display-buffer buffer-or-name not-this-window)
+ (popwin:display-buffer-1
+ buffer-or-name
+ :if-config-not-found
+ (unless (with-no-warnings
+ ;; FIXME: emacs bug?
+ (called-interactively-p))
+ (lambda (buffer)
+ (popwin:original-display-buffer buffer not-this-window))))))
+
+(defun popwin:special-display-popup-window (buffer &rest ignore)
+ "Obsolete."
+ (popwin:display-buffer-1 buffer))
+
+(defun* popwin:pop-to-buffer-1 (buffer
+ &key
+ default-config-keywords
+ other-window
+ norecord)
+ (popwin:display-buffer-1 buffer
+ :default-config-keywords default-config-keywords
+ :if-config-not-found
+ (lambda (buffer)
+ (pop-to-buffer buffer other-window norecord))))
+
+;;;###autoload
+(defun popwin:pop-to-buffer (buffer &optional other-window norecord)
+ "Same as `pop-to-buffer' except that this function will use
+`popwin:display-buffer-1' instead of `display-buffer'."
+ (interactive (list (read-buffer "Pop to buffer: " (other-buffer))
+ (if current-prefix-arg t)))
+ (popwin:pop-to-buffer-1 buffer
+ :other-window other-window
+ :norecord norecord))
+
+\f
+
+;;; Universal Display
+
+(defcustom popwin:universal-display-config '(t)
+ "Same as `popwin:special-display-config' except that this will
+be used for `popwin:universal-display'."
+ :group 'popwin)
+
+;;;###autoload
+(defun popwin:universal-display ()
+ "Call the following command interactively with letting
+`popwin:special-display-config' be
+`popwin:universal-display-config'. This wil be useful when
+displaying buffers in popup windows temporarily."
+ (interactive)
+ (let ((command (key-binding (read-key-sequence "" t)))
+ (popwin:special-display-config popwin:universal-display-config))
+ (call-interactively command)))
+
+\f
+
+;;; Extensions
+
+;;;###autoload
+(defun popwin:one-window ()
+ "Delete other window than the popup window. C-g restores the
+original window configuration."
+ (interactive)
+ (setq popwin:window-config (current-window-configuration))
+ (delete-other-windows))
+
+;;;###autoload
+(defun popwin:popup-buffer-tail (&rest same-as-popwin:popup-buffer)
+ "Same as `popwin:popup-buffer' except that the buffer will be
+`recenter'ed at the bottom."
+ (interactive "bPopup buffer:\n")
+ (destructuring-bind (buffer . keyargs) same-as-popwin:popup-buffer
+ (apply 'popwin:popup-buffer buffer :tail t keyargs)))
+
+;;;###autoload
+(defun popwin:find-file (filename &optional wildcards)
+ "Edit file FILENAME with popup window by `popwin:popup-buffer'."
+ (interactive
+ (find-file-read-args "Find file in popup window: "
+ (when (fboundp 'confirm-nonexistent-file-or-buffer)
+ (confirm-nonexistent-file-or-buffer))))
+ (popwin:popup-buffer (find-file-noselect filename wildcards)))
+
+;;;###autoload
+(defun popwin:find-file-tail (file &optional wildcard)
+ "Edit file FILENAME with popup window by
+`popwin:popup-buffer-tail'."
+ (interactive
+ (find-file-read-args "Find file in popup window: "
+ (when (fboundp 'confirm-nonexistent-file-or-buffer)
+ (confirm-nonexistent-file-or-buffer))))
+ (popwin:popup-buffer-tail (find-file-noselect file wildcard)))
+
+;;;###autoload
+(defun popwin:messages ()
+ "Display *Messages* buffer in a popup window."
+ (interactive)
+ (popwin:popup-buffer-tail "*Messages*"))
+
+\f
+
+;;; Minor Mode
+
+(defun popwin:display-buffer-condition (buffer action)
+ (and (popwin:match-config buffer) t))
+
+(defun popwin:display-buffer-action (buffer alist)
+ (let ((not-this-window (plist-get 'inhibit-same-window alist)))
+ (popwin:display-buffer buffer not-this-window)))
+
+(define-minor-mode popwin-mode
+ ""
+ :init-value nil
+ :global t
+ (if (boundp 'display-buffer-alist)
+ (let ((pair '(popwin:display-buffer-condition popwin:display-buffer-action)))
+ (if popwin-mode
+ (push pair display-buffer-alist)
+ (setq display-buffer-alist (delete pair display-buffer-alist))))
+ (with-no-warnings
+ (unless (or (null display-buffer-function)
+ (eq display-buffer-function 'popwin:display-buffer))
+ (warn "Overwriting display-buffer-function variable to enable/disable popwin-mode"))
+ (setq display-buffer-function (if popwin-mode 'popwin:display-buffer nil)))))
+
+\f
+
+;;; Keymaps
+
+(defvar popwin:keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map "b" 'popwin:popup-buffer)
+ (define-key map "l" 'popwin:popup-last-buffer)
+ (define-key map "o" 'popwin:display-buffer)
+ (define-key map "\C-b" 'popwin:switch-to-last-buffer)
+ (define-key map "\C-p" 'popwin:original-pop-to-last-buffer)
+ (define-key map "\C-o" 'popwin:original-display-last-buffer)
+ (define-key map " " 'popwin:select-popup-window)
+ (define-key map "s" 'popwin:stick-popup-window)
+ (define-key map "0" 'popwin:close-popup-window)
+ (define-key map "f" 'popwin:find-file)
+ (define-key map "\C-f" 'popwin:find-file)
+ (define-key map "e" 'popwin:messages)
+ (define-key map "\C-u" 'popwin:universal-display)
+ (define-key map "1" 'popwin:one-window)
+
+ map)
+ "Default keymap for popwin commands. Use like:
+\(global-set-key (kbd \"C-z\") popwin:keymap\)
+
+Keymap:
+
+| Key | Command |
+|--------+---------------------------------------|
+| b | popwin:popup-buffer |
+| l | popwin:popup-last-buffer |
+| o | popwin:display-buffer |
+| C-b | popwin:switch-to-last-buffer |
+| C-p | popwin:original-pop-to-last-buffer |
+| C-o | popwin:original-display-last-buffer |
+| SPC | popwin:select-popup-window |
+| s | popwin:stick-popup-window |
+| 0 | popwin:close-popup-window |
+| f, C-f | popwin:find-file |
+| e | popwin:messages |
+| C-u | popwin:universal-display |
+| 1 | popwin:one-window |")
+
+(provide 'popwin)
+;;; popwin.el ends here
projects / emacsconfig.git / commitdiff