home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / electric / ehelp.el < prev    next >
Encoding:
Text File  |  1993-03-14  |  11.0 KB  |  325 lines
  1. ;; Copyright (C) 1986, 1992 Free Software Foundation, Inc.
  2.  
  3. ;; This file is part of GNU Emacs.
  4.  
  5. ;; GNU Emacs is free software; you can redistribute it and/or modify
  6. ;; it under the terms of the GNU General Public License as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9.  
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;; GNU General Public License for more details.
  14.  
  15. ;; You should have received a copy of the GNU General Public License
  16. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  17. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19. ;; Written by Richard Mlynarik
  20.  
  21. (require 'electric)
  22. (provide 'ehelp) 
  23.  
  24. (defvar electric-help-map nil
  25.   "Keymap defining commands available whilst scrolling
  26. through a buffer in electric-help-mode")
  27.  
  28. (put 'electric-help-undefined 'suppress-keymap t)
  29. (if electric-help-map
  30.     ()
  31.   (let ((map (make-keymap)))
  32.     (set-keymap-name map 'electric-help-map)
  33.     (let ((i 0))
  34.       (while (< i 128)
  35.     (define-key map (make-string 1 i) 'electric-help-undefined)
  36.     (setq i (1+ i))))
  37.     ;;>>> Urk!  There should be a better way in Lucid Emacs!
  38.     (define-key map (char-to-string meta-prefix-char) (copy-keymap map))
  39.     (define-key map (char-to-string help-char) 'electric-help-help)
  40.     (define-key map "?" 'electric-help-help)
  41.     (define-key map " " 'scroll-up)
  42.     (define-key map "\^?" 'scroll-down)
  43.     (define-key map "." 'beginning-of-buffer)
  44.     (define-key map "<" 'beginning-of-buffer)
  45.     (define-key map ">" 'end-of-buffer)
  46.     ;(define-key map "\C-g" 'electric-help-exit)
  47.     (define-key map "q" 'electric-help-exit)
  48.     (define-key map "Q" 'electric-help-exit)
  49.     ;;a better key than this?
  50.     (define-key map "r" 'electric-help-retain)
  51.  
  52.     (setq electric-help-map map)))
  53.    
  54. (defun electric-help-mode ()
  55.   "`with-electric-help' temporarily places its buffer in this mode.
  56. \(On exit from `with-electric-help', the buffer is put in
  57.  `default-major-mode')"
  58.   (setq buffer-read-only t)
  59.   (setq mode-name "Help")
  60.   (setq major-mode 'help)
  61.   (setq mode-line-buffer-identification '(" Help:  %b"))
  62.   (use-local-map electric-help-map)
  63.   ;; this is done below in with-electric-help
  64.   ;(run-hooks 'electric-help-mode-hook)
  65.   )
  66.  
  67. (defun with-electric-help (thunk &optional buffer noerase)
  68.   "Arguments are THUNK &optional BUFFER NOERASE.
  69. BUFFER defaults to \"*Help*\"
  70. THUNK is a function of no arguments which is called to initialise
  71.  the contents of BUFFER.  BUFFER will be erased before THUNK is called unless
  72.  NOERASE is non-nil.  THUNK will be called with `standard-output' bound to
  73.  the buffer specified by BUFFER
  74.  
  75. After THUNK has been called, this function \"electrically\" pops up a window
  76. in which BUFFER is displayed and allows the user to scroll through that buffer
  77. in electric-help-mode.
  78. When the user exits (with `electric-help-exit', or otherwise) the help
  79. buffer's window disappears (ie we use `save-window-excursion')
  80. BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit."
  81.   (setq buffer (get-buffer-create (or buffer "*Help*")))
  82.   (let ((one (one-window-p t))
  83.         (config (current-window-configuration))
  84.         (bury nil))
  85.     (unwind-protect
  86.     (save-excursion
  87.       (if one (goto-char (window-start (selected-window))))
  88.       (let ((pop-up-windows t))
  89.         (pop-to-buffer buffer))
  90.       (save-excursion
  91.         (set-buffer buffer)
  92.         (electric-help-mode)
  93.         (setq buffer-read-only nil)
  94.         (or noerase (erase-buffer)))
  95.         (let ((standard-output buffer))
  96.           (if (not (funcall thunk))
  97.               (progn
  98.             (set-buffer buffer)
  99.             (set-buffer-modified-p nil)
  100.             (goto-char (point-min))
  101.             (if one (shrink-window-if-larger-than-buffer (selected-window))))))
  102.         (set-buffer buffer)
  103.         (run-hooks 'electric-help-mode-hook)
  104.                    (if (eq (car-safe (electric-help-command-loop))
  105.                    'retain)
  106.                (setq config (current-window-configuration))
  107.                (setq bury t)))
  108.       (message nil)
  109.       (set-buffer buffer)
  110.       (setq buffer-read-only nil)
  111.       (condition-case ()
  112.       (funcall (or default-major-mode 'fundamental-mode))
  113.     (error nil))
  114.       (set-window-configuration config)
  115.       (if bury
  116.           (progn
  117.             ;;>> Perhaps this shouldn't be done.
  118.             ;; so that when we say "Press space to bury" we mean it
  119.             (replace-buffer-in-windows buffer)
  120.             ;; must do this outside of save-window-excursion
  121.             (bury-buffer buffer))))))
  122.  
  123. (defun electric-help-command-loop ()
  124.   (catch 'exit
  125.     (if (pos-visible-in-window-p (point-max))
  126.     (progn (message "<<< Press Space to bury the help buffer >>>")
  127.            (if (eq (event-to-character
  128.             (setq unread-command-event
  129.                   (next-command-event (allocate-event))))
  130.                ?\ )
  131.            (progn (setq unread-command-event nil)
  132.               (throw 'exit t)))))
  133.     (let (up down both neither
  134.       (standard (and (eq (key-binding " ")
  135.                  'scroll-up)
  136.              (eq (key-binding "\^?")
  137.                  'scroll-down)
  138.              (eq (key-binding "Q")
  139.                  'electric-help-exit)
  140.              (eq (key-binding "q")
  141.                  'electric-help-exit))))
  142.       (Electric-command-loop
  143.         'exit
  144.     (function (lambda ()
  145.       (let ((min (pos-visible-in-window-p (point-min)))
  146.         (max (pos-visible-in-window-p (point-max))))
  147.         (cond ((and min max)
  148.            (cond (standard "Press Q to exit ")
  149.              (neither)
  150.              (t (setq neither (substitute-command-keys "Press \\[scroll-up] to exit ")))))
  151.           (min
  152.            (cond (standard "Press SPC to scroll, Q to exit ")
  153.              (up)
  154.              (t (setq up (substitute-command-keys "Press \\[scroll-up] to scroll; \\[electric-help-exit] to exit ")))))
  155.           (max
  156.            (cond (standard "Press DEL to scroll back, Q to exit ")
  157.              (down)
  158.              (t (setq down (substitute-command-keys "Press \\[scroll-down] to scroll back, \\[scroll-up] to exit ")))))
  159.           (t
  160.            (cond (standard "Press SPC to scroll, DEL to scroll back, Q to exit ")
  161.              (both)
  162.              (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit ")))))))))
  163.             t))))
  164.  
  165.  
  166.  
  167. ;(defun electric-help-scroll-up (arg)
  168. ;  ">>>Doc"
  169. ;  (interactive "P")
  170. ;  (if (and (null arg) (pos-visible-in-window-p (point-max)))
  171. ;      (electric-help-exit)
  172. ;    (scroll-up arg)))
  173.  
  174. (defun electric-help-exit ()
  175.   ">>>Doc"
  176.   (interactive)
  177.   (throw 'exit t))
  178.  
  179. (defun electric-help-retain ()
  180.   "Exit `electric-help', retaining the current window/buffer configuration.
  181. \(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET
  182. will select it.)"
  183.   (interactive)
  184.   (throw 'exit '(retain)))
  185.  
  186.  
  187. ;(defun electric-help-undefined ()
  188. ;  (interactive)
  189. ;  (let* ((keys (this-command-keys))
  190. ;     (n (length keys)))
  191. ;    (if (or (= n 1)
  192. ;        (and (= n 2)
  193. ;         meta-flag
  194. ;         (eq (aref keys 0) meta-prefix-char)))
  195. ;    (setq unread-command-char last-input-char
  196. ;          current-prefix-arg prefix-arg)
  197. ;      ;;>>> I don't care.
  198. ;      ;;>>> The emacs command-loop is too much pure pain to
  199. ;      ;;>>> duplicate
  200. ;      ))
  201. ;  (throw 'exit t))
  202.  
  203. (defun electric-help-undefined ()
  204.   (interactive)
  205.   (error "%s is undefined -- Press %s to exit"
  206.      (mapconcat 'single-key-description (this-command-keys) " ")
  207.      (if (eq (key-binding "Q") 'electric-help-exit)
  208.          "Q"
  209.        (substitute-command-keys "\\[electric-help-exit]"))))
  210.  
  211.  
  212. ;>>> this needs to be hairified (recursive help, anybody?)
  213. (defun electric-help-help ()
  214.   (interactive)
  215.   (if (and (eq (key-binding "Q") 'electric-help-exit)
  216.        (eq (key-binding " ") 'scroll-up)
  217.        (eq (key-binding "\^?") 'scroll-down))
  218.       (message "SPC scrolls forward, DEL scrolls back, Q exits and burys help buffer")
  219.     ;; to give something for user to look at while slow substitute-cmd-keys
  220.     ;;  grinds away
  221.     (message "Help...")
  222.     (message "%s" (substitute-command-keys "\\[scroll-up] scrolls forward, \\[scroll-down] scrolls back, \\[electric-help-exit] exits.")))
  223.   (sit-for 2))
  224.  
  225.  
  226. (defun electric-helpify (fun &optional buffer-name)
  227.   (or buffer-name (setq buffer-name "*Help*"))
  228.   (let* ((p (symbol-function 'print-help-return-message))
  229.          (b (get-buffer buffer-name))
  230.          (tick (and b (buffer-modified-tick b))))
  231.     (and b (not (get-buffer-window b))
  232.          (setq b nil))
  233.     (if (unwind-protect
  234.              (save-window-excursion
  235.                (message "%s..." (capitalize (symbol-name fun)))
  236.                ;; kludge-o-rama
  237.                (fset 'print-help-return-message 'ignore)
  238.                (let ((a (call-interactively fun 'lambda)))
  239.                  (let ((temp-buffer-show-function 'ignore))
  240.                    (apply fun a)))
  241.                (message nil)
  242.                ;; Was a non-empty help buffer created/modified?
  243.                (let ((r (get-buffer buffer-name)))
  244.                  (and r
  245.                       ;(get-buffer-window r)
  246.                       (or (not b)
  247.                           (not (eq b r))
  248.                           (not (eql tick (buffer-modified-tick b))))
  249.                       (save-excursion
  250.                         (set-buffer r)
  251.                         (> (buffer-size) 0)))))
  252.           (fset 'print-help-return-message p))
  253.         (with-electric-help 'ignore buffer-name t))))
  254.  
  255.  
  256. (defun electric-describe-key ()
  257.   (interactive)
  258.   (electric-helpify 'describe-key))
  259.  
  260. (defun electric-describe-mode ()
  261.   (interactive)
  262.   (electric-helpify 'describe-mode))
  263.  
  264. (defun electric-view-lossage ()
  265.   (interactive)
  266.   (electric-helpify 'view-lossage))
  267.  
  268. ;(defun electric-help-for-help ()
  269. ;  "See help-for-help"
  270. ;  (interactive)
  271. ;  )
  272.  
  273. (defun electric-describe-function ()
  274.   (interactive)
  275.   (electric-helpify 'describe-function))
  276.  
  277. (defun electric-describe-variable ()
  278.   (interactive)
  279.   (electric-helpify 'describe-variable))
  280.  
  281. (defun electric-describe-bindings ()
  282.   (interactive)
  283.   (electric-helpify 'describe-bindings))
  284.  
  285. (defun electric-describe-syntax ()
  286.   (interactive)
  287.   (electric-helpify 'describe-syntax))
  288.  
  289. (defun electric-command-apropos ()
  290.   (interactive)
  291.   (electric-helpify 'command-apropos))
  292.  
  293. ;(define-key help-map "a" 'electric-command-apropos)
  294.  
  295.  
  296.  
  297.  
  298. ;;;; ehelp-map
  299.  
  300. (defvar ehelp-map nil)
  301. (if ehelp-map
  302.     nil
  303.   (let ((shadow '((describe-key . electric-describe-key) 
  304.                   (describe-mode . electric-describe-mode)
  305.                   (view-lossage . electric-view-lossage) 
  306.                   (describe-function . electric-describe-function)
  307.                   (describe-variable . electric-describe-variable)
  308.                   (describe-bindings . electric-describe-bindings)
  309.                   (describe-syntax . electric-describe-syntax)))
  310.         (map (make-sparse-keymap)))
  311.     (set-keymap-name map 'ehelp-map)
  312.     (set-keymap-parent map help-map)
  313.     ;; Shadow bindings which would be inherited from help-map
  314.     ;;>>> This doesn't descend into sub-keymaps
  315.     (map-keymap (function (lambda (key binding)
  316.                               (let ((tem (assq binding shadow)))
  317.                                 (if tem
  318.                                     (define-key map key (cdr tem))))))
  319.                 help-map)
  320.     (setq ehelp-map map)
  321.     (fset 'ehelp-command map)))
  322.  
  323.  
  324. ;; Do (define-key global-map "\C-h" 'ehelp-command) if you want to win
  325.