elisp/geiser-popup.el

   1 ;;; geiser-popup.el -- popup windows
   2
   3 ;; Copyright (C) 2009, 2010, 2012, 2013 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Sat Feb 07, 2009 14:05
  11
  12 \f
  13 ;;; Code:
  14
  15 (require 'view)
  16
  17 \f
  18 ;;; Support for defining popup buffers and accessors:
  19
  20 (defvar geiser-popup--registry nil)
  21
  22 (defvar geiser-popup--overriding-map
  23   (let ((map (make-sparse-keymap)))
  24     (define-key map "q" 'View-quit)
  25     map))
  26
  27 (defun geiser-popup--setup-view-mode ()
  28   (view-mode t)
  29   (set (make-local-variable 'view-no-disable-on-exit) t)
  30   (set (make-local-variable 'minor-mode-overriding-map-alist)
  31        (list (cons 'view-mode geiser-popup--overriding-map)))
  32   (setq view-exit-action
  33         (lambda (buffer)
  34           (with-current-buffer buffer
  35             (bury-buffer)))))
  36
  37 (defmacro geiser-popup--define (base name mode)
  38   (let ((get-buff (intern (format "geiser-%s--buffer" base)))
  39         (pop-buff (intern (format "geiser-%s--pop-to-buffer" base)))
  40         (with-macro (intern (format "geiser-%s--with-buffer" base)))
  41         (method (make-symbol "method"))
  42         (buffer (make-symbol "buffer")))
  43     `(progn
  44        (add-to-list 'geiser-popup--registry ,name)
  45        (defun ,get-buff ()
  46          (or (get-buffer ,name)
  47              (with-current-buffer (get-buffer-create ,name)
  48                (funcall ',mode)
  49                (geiser-popup--setup-view-mode)
  50                (current-buffer))))
  51        (defun ,pop-buff (&optional ,method)
  52          (let ((,buffer (funcall ',get-buff)))
  53            (unless (eq ,buffer (current-buffer))
  54              (cond ((eq ,method 'buffer) (view-buffer ,buffer))
  55                    ((eq ,method 'frame) (view-buffer-other-frame ,buffer))
  56                    (t (view-buffer-other-window ,buffer))))))
  57        (defmacro ,with-macro (&rest body)
  58          (declare (debug (&rest form)))
  59          (list 'with-current-buffer (list ',get-buff)
  60                (cons 'let (cons '((inhibit-read-only t)) body))))
  61        (put ',with-macro 'lisp-indent-function 'defun))))
  62
  63 (put 'geiser-popup--define 'lisp-indent-function 1)
  64
  65 \f
  66 ;;; Reload support:
  67
  68 (defun geiser-popup-unload-function ()
  69   (dolist (name geiser-popup--registry)
  70     (when (buffer-live-p (get-buffer name))
  71       (kill-buffer name))))
  72
  73 \f
  74 (provide 'geiser-popup)