code.delx.au - gnu-emacs-elpa/blob - packages/temp-buffer-browse/temp-buffer-browse.el

   1 ;;; temp-buffer-browse.el --- temp buffer browse mode  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2013-2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Leo Liu <sdl.web@gmail.com>
   6 ;; Version: 1.3
   7 ;; Keywords: convenience
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; Allow keys `SPC', `DEL' and `RET' following a temp buffer popup to
  25 ;; scroll up, scroll down and close the temp buffer window,
  26 ;; respectively.
  27
  28 ;;; Code:
  29
  30 ;; fringe not preloaded for tty emacs
  31 (eval-when-compile (require 'fringe))
  32
  33 (eval-and-compile
  34   (cond
  35    ((fboundp 'set-transient-map) nil)
  36    ((fboundp 'set-temporary-overlay-map) ; new in 24.3
  37     (defalias 'set-transient-map 'set-temporary-overlay-map))
  38    (t
  39     (defun set-transient-map (map &optional keep-pred)
  40       (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map"))
  41              (overlaysym (make-symbol "t"))
  42              (alist (list (cons overlaysym map)))
  43              (clearfun
  44               `(lambda ()
  45                  (unless ,(cond ((null keep-pred) nil)
  46                                 ((eq t keep-pred)
  47                                  `(eq this-command
  48                                       (lookup-key ',map
  49                                                   (this-command-keys-vector))))
  50                                 (t `(funcall ',keep-pred)))
  51                    (set ',overlaysym nil) ;Just in case.
  52                    (remove-hook 'pre-command-hook ',clearfunsym)
  53                    (setq emulation-mode-map-alists
  54                          (delq ',alist emulation-mode-map-alists))))))
  55         (set overlaysym overlaysym)
  56         (fset clearfunsym clearfun)
  57         (add-hook 'pre-command-hook clearfunsym)
  58         (push alist emulation-mode-map-alists))))))
  59
  60 (defcustom temp-buffer-browse-fringe-bitmap 'centered-vertical-bar
  61   "Fringe bitmap to use in the temp buffer window."
  62   :type `(restricted-sexp :match-alternatives
  63                           (,(lambda (s) (and (symbolp s) (fringe-bitmap-p s)))))
  64   :group 'help)
  65
  66 (defvar temp-buffer-browse--window nil)
  67
  68 ;; See http://debbugs.gnu.org/15497
  69 (unless (fringe-bitmap-p 'centered-vertical-bar)
  70   (define-fringe-bitmap 'centered-vertical-bar [24] nil nil '(top t)))
  71
  72 (defvar temp-buffer-browse-map
  73   (let ((map (make-sparse-keymap))
  74         (quit (lambda ()
  75                 (interactive)
  76                 (when (window-live-p temp-buffer-browse--window)
  77                   (quit-window nil temp-buffer-browse--window))))
  78         (up (lambda ()
  79               (interactive)
  80               (when (window-live-p temp-buffer-browse--window)
  81                 (with-selected-window temp-buffer-browse--window
  82                   (condition-case nil
  83                       (scroll-up)
  84                     (end-of-buffer (quit-window)))))))
  85         (down (lambda ()
  86                 (interactive)
  87                 (when (window-live-p temp-buffer-browse--window)
  88                   (with-selected-window temp-buffer-browse--window
  89                     (scroll-up '-))))))
  90     (define-key map "\C-m" quit)
  91     (define-key map [return] quit)
  92     (define-key map " " up)
  93     (define-key map (kbd "DEL") down)
  94     (define-key map [delete] down)
  95     (define-key map [backspace] down)
  96     map))
  97
  98 ;;;###autoload
  99 (defun temp-buffer-browse-activate ()
 100   "Activate temporary key bindings for current window.
 101 Specifically set up keys `SPC', `DEL' and `RET' to scroll up,
 102 scroll down and close the temp buffer window, respectively."
 103   (unless (derived-mode-p 'completion-list-mode)
 104     (setq temp-buffer-browse--window (selected-window))
 105     ;; When re-using existing window don't call
 106     ;; `fit-window-to-buffer'. See also (info "(elisp)Window
 107     ;; Parameters").
 108     (when (and (window-full-width-p)
 109                (memq (cadr (window-parameter nil 'quit-restore))
 110                      '(window frame)))
 111       (fit-window-to-buffer nil (floor (frame-height) 2))
 112       ;; In case buffer contents are inserted asynchronously such as
 113       ;; in `slime-inspector-mode'.
 114       (add-hook 'after-change-functions
 115                 (let ((time (float-time)))
 116                   (lambda (&rest _)
 117                     (when (> (float-time) (+ 0.05 time))
 118                       (fit-window-to-buffer nil (floor (frame-height) 2))
 119                       (setq time (float-time)))))
 120                 nil 'local))
 121     (let ((o (make-overlay (point-min) (point-max))))
 122       (overlay-put o 'evaporate t)
 123       (overlay-put o 'window t)
 124       (overlay-put o 'line-prefix
 125                    (propertize
 126                     "|" 'display
 127                     (unless (zerop (or (frame-parameter nil 'left-fringe) 0))
 128                       `(left-fringe ,temp-buffer-browse-fringe-bitmap warning))
 129                     'face 'warning))
 130       ;; NOTE: breaks `adaptive-wrap-prefix-mode' because overlay's
 131       ;; wrap-prefix overrides text property's. Overlay's cannot have
 132       ;; negative priority.
 133       (unless (bound-and-true-p adaptive-wrap-prefix-mode)
 134         (overlay-put o 'wrap-prefix (overlay-get o 'line-prefix)))
 135       (set-transient-map
 136        temp-buffer-browse-map
 137        (lambda ()
 138          ;; When any error happens the keymap is active forever.
 139          (with-demoted-errors
 140            (or (and (window-live-p temp-buffer-browse--window)
 141                     (not (member (this-command-keys) '("\C-m" [return])))
 142                     (eq this-command (lookup-key temp-buffer-browse-map
 143                                                  (this-command-keys))))
 144                (ignore (overlay-put o 'line-prefix nil)
 145                        (overlay-put o 'wrap-prefix nil)))))))))
 146
 147 ;;;###autoload
 148 (define-minor-mode temp-buffer-browse-mode nil
 149   :lighter ""
 150   :global t
 151   ;; Work around http://debbugs.gnu.org/16038
 152   (let ((activate (lambda ()
 153                     (unless (derived-mode-p 'fundamental-mode)
 154                       (temp-buffer-browse-activate)))))
 155     (if temp-buffer-browse-mode
 156         (progn
 157           (add-hook 'temp-buffer-show-hook 'temp-buffer-browse-activate t)
 158           (add-hook 'temp-buffer-window-show-hook activate t))
 159       (remove-hook 'temp-buffer-show-hook 'temp-buffer-browse-activate)
 160       (remove-hook 'temp-buffer-window-show-hook activate))))
 161
 162 (provide 'temp-buffer-browse)
 163 ;;; temp-buffer-browse.el ends here