elisp/geiser-popup.el

   1 ;; geiser-popup.el -- popup windows
   2
   3 ;; Copyright (C) 2009, 2010, 2012 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 (require 'view)
  13
  14 \f
  15 ;;; Support for defining popup buffers and accessors:
  16
  17 (defvar geiser-popup--registry nil)
  18
  19 (setq geiser-popup--overriding-map
  20   (let ((map (make-sparse-keymap)))
  21     (define-key map "q" 'View-quit)
  22     map))
  23
  24 (defun geiser-popup--setup-view-mode ()
  25   (view-mode t)
  26   (set (make-local-variable 'view-no-disable-on-exit) t)
  27   (set (make-local-variable 'minor-mode-overriding-map-alist)
  28        (list (cons 'view-mode geiser-popup--overriding-map)))
  29   (setq view-exit-action
  30         (lambda (buffer)
  31           (with-current-buffer buffer
  32             (bury-buffer)))))
  33
  34 (defmacro geiser-popup--define (base name mode)
  35   (let ((get-buff (intern (format "geiser-%s--buffer" base)))
  36         (pop-buff (intern (format "geiser-%s--pop-to-buffer" base)))
  37         (with-macro (intern (format "geiser-%s--with-buffer" base)))
  38         (method (make-symbol "method"))
  39         (buffer (make-symbol "buffer")))
  40   `(progn
  41      (add-to-list 'geiser-popup--registry ,name)
  42      (defun ,get-buff ()
  43        (or (get-buffer ,name)
  44            (with-current-buffer (get-buffer-create ,name)
  45              (funcall ',mode)
  46              (geiser-popup--setup-view-mode)
  47              (current-buffer))))
  48      (defun ,pop-buff (&optional ,method)
  49        (let ((,buffer (funcall ',get-buff)))
  50          (unless (eq ,buffer (current-buffer))
  51            (cond ((eq ,method 'buffer) (view-buffer ,buffer))
  52                  ((eq ,method 'frame) (view-buffer-other-frame ,buffer))
  53                  (t (view-buffer-other-window ,buffer))))))
  54      (defmacro ,with-macro (&rest body)
  55        (list 'with-current-buffer (list ',get-buff)
  56              (cons 'let (cons '((inhibit-read-only t)) body))))
  57      (put ',with-macro 'lisp-indent-function 'defun))))
  58
  59 (put 'geiser-popup--define 'lisp-indent-function 1)
  60
  61 \f
  62 ;;; Reload support:
  63
  64 (defun geiser-popup-unload-function ()
  65   (dolist (name geiser-popup--registry)
  66     (when (buffer-live-p (get-buffer name))
  67       (kill-buffer name))))
  68
  69 \f
  70 (provide 'geiser-popup)