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.4
   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 (when (and (fboundp 'define-fringe-bitmap) ;only defined in GUI.
  70            (not (fringe-bitmap-p 'centered-vertical-bar)))
  71   (define-fringe-bitmap 'centered-vertical-bar [24] nil nil '(top t)))
  72
  73 (defvar temp-buffer-browse-map
  74   (let ((map (make-sparse-keymap))
  75         (quit (lambda ()
  76                 (interactive)
  77                 (when (window-live-p temp-buffer-browse--window)
  78                   (quit-window nil temp-buffer-browse--window))))
  79         (up (lambda ()
  80               (interactive)
  81               (when (window-live-p temp-buffer-browse--window)
  82                 (with-selected-window temp-buffer-browse--window
  83                   (condition-case nil
  84                       (scroll-up)
  85                     (end-of-buffer (quit-window)))))))
  86         (down (lambda ()
  87                 (interactive)
  88                 (when (window-live-p temp-buffer-browse--window)
  89                   (with-selected-window temp-buffer-browse--window
  90                     (scroll-up '-))))))
  91     (define-key map "\C-m" quit)
  92     (define-key map [return] quit)
  93     (define-key map " " up)
  94     (define-key map (kbd "DEL") down)
  95     (define-key map [delete] down)
  96     (define-key map [backspace] down)
  97     map))
  98
  99 ;;;###autoload
 100 (defun temp-buffer-browse-activate ()
 101   "Activate temporary key bindings for current window.
 102 Specifically set up keys `SPC', `DEL' and `RET' to scroll up,
 103 scroll down and close the temp buffer window, respectively."
 104   (unless (derived-mode-p 'completion-list-mode)
 105     (setq temp-buffer-browse--window (selected-window))
 106     ;; When re-using existing window don't call
 107     ;; `fit-window-to-buffer'. See also (info "(elisp)Window
 108     ;; Parameters").
 109     (when (and (window-full-width-p)
 110                (memq (cadr (window-parameter nil 'quit-restore))
 111                      '(window frame)))
 112       (fit-window-to-buffer nil (floor (frame-height) 2))
 113       ;; In case buffer contents are inserted asynchronously such as
 114       ;; in `slime-inspector-mode'.
 115       (add-hook 'after-change-functions
 116                 (let ((time (float-time)))
 117                   (lambda (&rest _)
 118                     (when (> (float-time) (+ 0.05 time))
 119                       (fit-window-to-buffer nil (floor (frame-height) 2))
 120                       (setq time (float-time)))))
 121                 nil 'local))
 122     (let ((o (make-overlay (point-min) (point-max))))
 123       (overlay-put o 'evaporate t)
 124       (overlay-put o 'window t)
 125       (overlay-put o 'line-prefix
 126                    (propertize
 127                     "|" 'display
 128                     (unless (zerop (or (frame-parameter nil 'left-fringe) 0))
 129                       `(left-fringe ,temp-buffer-browse-fringe-bitmap warning))
 130                     'face 'warning))
 131       ;; NOTE: breaks `adaptive-wrap-prefix-mode' because overlay's
 132       ;; wrap-prefix overrides text property's. Overlay's cannot have
 133       ;; negative priority.
 134       (unless (bound-and-true-p adaptive-wrap-prefix-mode)
 135         (overlay-put o 'wrap-prefix (overlay-get o 'line-prefix)))
 136       (set-transient-map
 137        temp-buffer-browse-map
 138        (lambda ()
 139          ;; When any error happens the keymap is active forever.
 140          (with-demoted-errors
 141            (or (and (window-live-p temp-buffer-browse--window)
 142                     (not (member (this-command-keys) '("\C-m" [return])))
 143                     (eq this-command (lookup-key temp-buffer-browse-map
 144                                                  (this-command-keys))))
 145                (ignore (overlay-put o 'line-prefix nil)
 146                        (overlay-put o 'wrap-prefix nil)))))))))
 147
 148 ;;;###autoload
 149 (define-minor-mode temp-buffer-browse-mode nil
 150   :lighter ""
 151   :global t
 152   ;; Work around http://debbugs.gnu.org/16038
 153   (let ((activate (lambda ()
 154                     (unless (derived-mode-p 'fundamental-mode)
 155                       (temp-buffer-browse-activate)))))
 156     (if temp-buffer-browse-mode
 157         (progn
 158           (add-hook 'temp-buffer-show-hook 'temp-buffer-browse-activate t)
 159           (add-hook 'temp-buffer-window-show-hook activate t))
 160       (remove-hook 'temp-buffer-show-hook 'temp-buffer-browse-activate)
 161       (remove-hook 'temp-buffer-window-show-hook activate))))
 162
 163 (provide 'temp-buffer-browse)
 164 ;;; temp-buffer-browse.el ends here