home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / NeXT / GnuSource / emacs-15.0.3 / lisp / ehelp.el < prev    next >
Lisp/Scheme  |  1990-07-19  |  12KB  |  340 lines
  1. ;; Copyright (C) 1986 Free Software Foundation, Inc.
  2.  
  3. ;; This file is part of GNU Emacs.
  4.  
  5. ;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  7. ;; accepts responsibility to anyone for the consequences of using it
  8. ;; or for whether it serves any particular purpose or works at all,
  9. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  10. ;; License for full details.
  11.  
  12. ;; Everyone is granted permission to copy, modify and redistribute
  13. ;; GNU Emacs, but only under the conditions described in the
  14. ;; GNU Emacs General Public License.   A copy of this license is
  15. ;; supposed to have been given to you along with GNU Emacs so you
  16. ;; can know your rights and responsibilities.  It should be in a
  17. ;; file named COPYING.  Among other things, the copyright notice
  18. ;; and this notice must be preserved on all copies.
  19.  
  20. (require 'electric)
  21. (provide 'ehelp) 
  22.  
  23. (defvar electric-help-map ()
  24.   "Keymap defining commands available whilst scrolling
  25. through a buffer in electric-help-mode")
  26.  
  27. (put 'electric-help-undefined 'suppress-keymap t)
  28. (if electric-help-map
  29.     ()
  30.   (let ((map (make-keymap)))
  31.     (fillarray map 'electric-help-undefined)
  32.     (define-key map (char-to-string meta-prefix-char) (copy-keymap map))
  33.     (define-key map (char-to-string help-char) 'electric-help-help)
  34.     (define-key map "?" 'electric-help-help)
  35.     (define-key map " " 'scroll-up)
  36.     (define-key map "\^?" 'scroll-down)
  37.     (define-key map "." 'beginning-of-buffer)
  38.     (define-key map "<" 'beginning-of-buffer)
  39.     (define-key map ">" 'end-of-buffer)
  40.     ;(define-key map "\C-g" 'electric-help-exit)
  41.     (define-key map "q" 'electric-help-exit)
  42.     (define-key map "Q" 'electric-help-exit)
  43.     ;;a better key than this?
  44.     (define-key map "r" 'electric-help-retain)
  45.  
  46.     (setq electric-help-map map)))
  47.    
  48. (defun electric-help-mode ()
  49.   "with-electric-help temporarily places its buffer in this mode
  50. \(On exit from with-electric-help, the buffer is put in default-major-mode)"
  51.   (setq buffer-read-only t)
  52.   (setq mode-name "Help")
  53.   (setq major-mode 'help)
  54.   (setq mode-line-buffer-identification '(" Help:  %b"))
  55.   (use-local-map electric-help-map)
  56.   ;; this is done below in with-electric-help
  57.   ;(run-hooks 'electric-help-mode-hook)
  58.   )
  59.  
  60. (defun with-electric-help (thunk &optional buffer noerase)
  61.   "Arguments are THUNK &optional BUFFER NOERASE.
  62. BUFFER defaults to \"*Help*\"
  63. THUNK is a function of no arguments which is called to initialise
  64.  the contents of BUFFER.  BUFFER will be erased before THUNK is called unless
  65.  NOERASE is non-nil.  THUNK will be called with  standard-output  bound to
  66.  the buffer specified by BUFFER
  67.  
  68. After THUNK has been called, this function \"electrically\" pops up a window
  69. in which BUFFER is displayed and allows the user to scroll through that buffer
  70. in electric-help-mode.
  71. When the user exits (with electric-help-exit, or otherwise) the help
  72. buffer's window disappears (ie we use save-window-excursion)
  73. BUFFER is put into default-major-mode (or fundamental-mode) when we exit"
  74.   (setq buffer (get-buffer-create (or buffer "*Help*")))
  75.   (let ((one (one-window-p t))
  76.     (two nil))
  77.     (save-window-excursion
  78.       (save-excursion
  79.     (if one (goto-char (window-start (selected-window))))
  80.     (let ((pop-up-windows t))
  81.       (pop-to-buffer buffer))
  82.     (unwind-protect
  83.         (progn
  84.           (save-excursion
  85.         (set-buffer buffer)
  86.         (electric-help-mode)
  87.         (setq buffer-read-only nil)
  88.         (or noerase (erase-buffer)))
  89.           (let ((standard-output buffer))
  90.         (if (funcall thunk)
  91.             ()
  92.           (set-buffer buffer)
  93.           (set-buffer-modified-p nil)
  94.           (goto-char (point-min))
  95.           (if one (shrink-window-if-larger-than-buffer (selected-window)))))
  96.           (set-buffer buffer)
  97.           (run-hooks 'electric-help-mode-hook)
  98.           (setq two (electric-help-command-loop))
  99.           (cond ((eq (car-safe two) 'retain)
  100.              (setq two (vector (window-height (selected-window))
  101.                        (window-start (selected-window))
  102.                        (window-hscroll (selected-window))
  103.                        (point))))
  104.             (t (setq two nil))))
  105.                   
  106.       (message "")
  107.       (set-buffer buffer)
  108.       (setq buffer-read-only nil)
  109.       (condition-case ()
  110.           (funcall (or default-major-mode 'fundamental-mode))
  111.         (error nil)))))
  112.     (if two
  113.     (let ((pop-up-windows t)
  114.           tem)
  115.       (pop-to-buffer buffer)
  116.       (setq tem (- (window-height (selected-window)) (elt two 0)))
  117.       (if (> tem 0) (shrink-window tem))
  118.       (set-window-start (selected-window) (elt two 1) t)
  119.       (set-window-hscroll (selected-window) (elt two 2))
  120.       (goto-char (elt two 3)))
  121.       ;;>> Perhaps this shouldn't be done.
  122.       ;; so that when we say "Press space to bury" we mean it
  123.       (replace-buffer-in-windows buffer)
  124.       ;; must do this outside of save-window-excursion
  125.       (bury-buffer buffer))))
  126.  
  127. (defun electric-help-command-loop ()
  128.   (catch 'exit
  129.     (if (pos-visible-in-window-p (point-max))
  130.     (progn (message "<<< Press Space to bury the help buffer >>>")
  131.            (if (= (setq unread-command-char (read-char)) ?\  )
  132.            (progn (setq unread-command-char -1)
  133.               (throw 'exit t)))))
  134.     (let (up down both neither
  135.       (standard (and (eq (key-binding " ")
  136.                  'scroll-up)
  137.              (eq (key-binding "\^?")
  138.                  'scroll-down)
  139.              (eq (key-binding "Q")
  140.                  'electric-help-exit)
  141.              (eq (key-binding "q")
  142.                  'electric-help-exit))))
  143.       (Electric-command-loop
  144.         'exit
  145.     (function (lambda ()
  146.       (let ((min (pos-visible-in-window-p (point-min)))
  147.         (max (pos-visible-in-window-p (point-max))))
  148.         (cond ((and min max)
  149.            (cond (standard "Press Q to exit ")
  150.              (neither)
  151.              (t (setq neither (substitute-command-keys "Press \\[scroll-up] to exit ")))))
  152.           (min
  153.            (cond (standard "Press SPC to scroll, Q to exit ")
  154.              (up)
  155.              (t (setq up (substitute-command-keys "Press \\[scroll-up] to scroll; \\[electric-help-exit] to exit ")))))
  156.           (max
  157.            (cond (standard "Press DEL to scroll back, Q to exit ")
  158.              (down)
  159.              (t (setq down (substitute-command-keys "Press \\[scroll-down] to scroll back, \\[scroll-up] to exit ")))))
  160.           (t
  161.            (cond (standard "Press SPC to scroll, DEL to scroll back, Q to exit ")
  162.              (both)
  163.              (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit ")))))))))
  164.             t))))
  165.  
  166.  
  167.  
  168. ;(defun electric-help-scroll-up (arg)
  169. ;  ">>>Doc"
  170. ;  (interactive "P")
  171. ;  (if (and (null arg) (pos-visible-in-window-p (point-max)))
  172. ;      (electric-help-exit)
  173. ;    (scroll-up arg)))
  174.  
  175. (defun electric-help-exit ()
  176.   ">>>Doc"
  177.   (interactive)
  178.   (throw 'exit t))
  179.  
  180. (defun electric-help-retain ()
  181.   "Exit electric-help, retaining the current window/buffer conifiguration.
  182. \(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET
  183. will select it.)"
  184.   (interactive)
  185.   (throw 'exit '(retain)))
  186.  
  187.  
  188. ;(defun electric-help-undefined ()
  189. ;  (interactive)
  190. ;  (let* ((keys (this-command-keys))
  191. ;     (n (length keys)))
  192. ;    (if (or (= n 1)
  193. ;        (and (= n 2)
  194. ;         meta-flag
  195. ;         (eq (aref keys 0) meta-prefix-char)))
  196. ;    (setq unread-command-char last-input-char
  197. ;          current-prefix-arg prefix-arg)
  198. ;      ;;>>> I don't care.
  199. ;      ;;>>> The emacs command-loop is too much pure pain to
  200. ;      ;;>>> duplicate
  201. ;      ))
  202. ;  (throw 'exit t))
  203.  
  204. (defun electric-help-undefined ()
  205.   (interactive)
  206.   (error "%s is undefined -- Press %s to exit"
  207.      (mapconcat 'single-key-description (this-command-keys) " ")
  208.      (if (eq (key-binding "Q") 'electric-help-exit)
  209.          "Q"
  210.        (substitute-command-keys "\\[electric-help-exit]"))))
  211.  
  212.  
  213. ;>>> this needs to be hairified (recursive help, anybody?)
  214. (defun electric-help-help ()
  215.   (interactive)
  216.   (if (and (eq (key-binding "Q") 'electric-help-exit)
  217.        (eq (key-binding " ") 'scroll-up)
  218.        (eq (key-binding "\^?") 'scroll-down))
  219.       (message "SPC scrolls forward, DEL scrolls back, Q exits and burys help buffer")
  220.     ;; to give something for user to look at while slow substitute-cmd-keys
  221.     ;;  grinds away
  222.     (message "Help...")
  223.     (message "%s" (substitute-command-keys "\\[scroll-up] scrolls forward, \\[scroll-down] scrolls back, \\[electric-help-exit] exits.")))
  224.   (sit-for 2))
  225.  
  226.  
  227. (defun electric-helpify (fun)
  228.   (let ((name "*Help*"))
  229.     (if (save-window-excursion
  230.       ;; kludge-o-rama
  231.       (let* ((p (symbol-function 'print-help-return-message))
  232.          (b (get-buffer name))
  233.          (m (buffer-modified-p b)))
  234.         (and b (not (get-buffer-window b))
  235.          (setq b nil))
  236.         (unwind-protect
  237.         (progn
  238.           (message "%s..." (capitalize (symbol-name fun)))
  239.           ;; with-output-to-temp-buffer marks the buffer as unmodified.
  240.           ;; kludging excessively and relying on that as some sort
  241.           ;;  of indication leads to the following abomination...
  242.           ;;>> This would be doable without such icky kludges if either
  243.           ;;>> (a) there were a function to read the interactive
  244.           ;;>>     args for a command and return a list of those args.
  245.           ;;>>     (To which one would then just apply the command)
  246.           ;;>>     (The only problem with this is that interactive-p
  247.           ;;>>      would break, but that is such a misfeature in
  248.           ;;>>      any case that I don't care)
  249.           ;;>>     It is easy to do this for emacs-lisp functions;
  250.           ;;>>     the only problem is getting the interactive spec
  251.           ;;>>     for subrs
  252.           ;;>> (b) there were a function which returned a
  253.           ;;>>     modification-tick for a buffer.  One could tell
  254.           ;;>>     whether a buffer had changed by whether the
  255.           ;;>>     modification-tick were different.
  256.           ;;>>     (Presumably there would have to be a way to either
  257.           ;;>>      restore the tick to some previous value, or to
  258.           ;;>>      suspend updating of the tick in order to allow
  259.           ;;>>      things like momentary-string-display)
  260.           (and b
  261.                (save-excursion
  262.              (set-buffer b)
  263.              (set-buffer-modified-p t)))
  264.           (fset 'print-help-return-message 'ignore)
  265.           (call-interactively fun)
  266.           (and (get-buffer name)
  267.                (get-buffer-window (get-buffer name))
  268.                (or (not b)
  269.                (not (eq b (get-buffer name)))
  270.                (not (buffer-modified-p b)))))
  271.           (fset 'print-help-return-message p)
  272.           (and b (buffer-name b)
  273.            (save-excursion
  274.              (set-buffer b)
  275.              (set-buffer-modified-p m))))))
  276.     (with-electric-help 'ignore name t))))
  277.  
  278.  
  279. (defun electric-describe-key ()
  280.   (interactive)
  281.   (electric-helpify 'describe-key))
  282.  
  283. (defun electric-describe-mode ()
  284.   (interactive)
  285.   (electric-helpify 'describe-mode))
  286.  
  287. (defun electric-view-lossage ()
  288.   (interactive)
  289.   (electric-helpify 'view-lossage))
  290.  
  291. ;(defun electric-help-for-help ()
  292. ;  "See help-for-help"
  293. ;  (interactive)
  294. ;  )
  295.  
  296. (defun electric-describe-function ()
  297.   (interactive)
  298.   (electric-helpify 'describe-function))
  299.  
  300. (defun electric-describe-variable ()
  301.   (interactive)
  302.   (electric-helpify 'describe-variable))
  303.  
  304. (defun electric-describe-bindings ()
  305.   (interactive)
  306.   (electric-helpify 'describe-bindings))
  307.  
  308. (defun electric-describe-syntax ()
  309.   (interactive)
  310.   (electric-helpify 'describe-syntax))
  311.  
  312. (defun electric-command-apropos ()
  313.   (interactive)
  314.   (electric-helpify 'command-apropos))
  315.  
  316. ;(define-key help-map "a" 'electric-command-apropos)
  317.  
  318.  
  319.  
  320.  
  321. ;;;; ehelp-map
  322.  
  323. (defvar ehelp-map ())
  324. (if ehelp-map
  325.     nil
  326.   (let ((map (copy-keymap help-map))) 
  327.     (substitute-key-definition 'describe-key 'electric-describe-key map)
  328.     (substitute-key-definition 'describe-mode 'electric-describe-mode map)
  329.     (substitute-key-definition 'view-lossage 'electric-view-lossage map)
  330.     (substitute-key-definition 'describe-function 'electric-describe-function map)
  331.     (substitute-key-definition 'describe-variable 'electric-describe-variable map)
  332.     (substitute-key-definition 'describe-bindings 'electric-describe-bindings map)
  333.     (substitute-key-definition 'describe-syntax 'electric-describe-syntax map)
  334.  
  335.     (setq ehelp-map map)
  336.     (fset 'ehelp-command map)))
  337.  
  338. ;; Do (define-key global-map "\C-h" 'ehelp-command) if you want to win
  339.  
  340.