home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / epoch / mouse-help.el < prev    next >
Encoding:
Text File  |  1991-03-30  |  14.3 KB  |  341 lines
  1. ; Date: Tue, 9 Oct 90 14:48:23 EDT
  2. ; From: Ken Laprade <laprade@trantor.harris-atd.com>
  3. ; Subject: mouse.el enhancements and mouse-help.el
  4. ; 
  5. ; The changes to epoch::coords-to-point in mouse.c that I sent in last month
  6. ; allow the mouse::handler to distinguish between button events actually in a
  7. ; window, on a mode line, or in the (inactive) minibuffer area.  Here is the
  8. ; mouse.el that I am now using.  I have added support for separate
  9. ; mouse-map's for each of these three areas.  There are also some functions
  10. ; and sample mouse bindings for things that do not require motion (those are
  11. ; in motion.el).
  12. ; 
  13. ; I have also included mouse-help.el.  This contains describe-mouse and
  14. ; describe-mouse-briefly, which accept a mouse press and print documentation
  15. ; on its binding, and mouse-helper, which pops up a small screen listing the
  16. ; mouse::global-map bindings.  All expect to be used with my version of
  17. ; mouse.el.
  18. ; 
  19. ; -- 
  20. ; Ken Laprade            INTERNET: laprade@trantor.harris-atd.com
  21. ; Harris Corporation         Usenet:  ...!uunet!x102a!trantor!laprade
  22. ; PO Box 37, MS 3A/1912        Voice: (407)727-4433
  23. ; Melbourne, FL 32902        FAX: (407)729-2537
  24. ; 
  25. ; 
  26. ;;; Copyright (C) 1990  Kenneth C. Laprade <laprade@trantor.harris-atd.com>
  27. ;;;
  28. ;;; This file is for use with Epoch, a modified version of GNU Emacs.
  29. ;;; Requires Epoch 3.2 with my patch to mouse.c.
  30. ;;;
  31. ;;; This code is distributed in the hope that it will be useful,
  32. ;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts
  33. ;;; responsibility to anyone for the consequences of using this code
  34. ;;; or for whether it serves any particular purpose or works at all,
  35. ;;; unless explicitly stated in a written agreement.
  36. ;;;
  37. ;;; Everyone is granted permission to copy, modify and redistribute
  38. ;;; this code, but only under the conditions described in the
  39. ;;; GNU Emacs General Public License, except the original author nor his
  40. ;;; agents are bound by the License in their use of this code.
  41. ;;; (These special rights for the author in no way restrict the rights of
  42. ;;;  others given in the License or this prologue)
  43. ;;; A copy of this license is supposed to have been given to you along
  44. ;;; with Epoch so you can know your rights and responsibilities. 
  45. ;;; It should be in a file named COPYING.  Among other things, the
  46. ;;; copyright notice and this notice must be preserved on all copies. 
  47.  
  48. ;;; This file provides two things:
  49. ;;;    The functions describe-mouse and describe-mouse-briefly accept a mouse
  50. ;;; press and give documetation on the bindings to both the up and down
  51. ;;; events.
  52. ;;;    The function mouse-helper pops up an epoch screen with a buffer listing
  53. ;;; all the mouse bindings.  Only one set of bindings is shown at a time.
  54. ;;; Pressing the mouse on a keyword in the mode line will change the set of
  55. ;;; bindings that is displayed.
  56.  
  57.  
  58. ;;; Mouse help:
  59. (defun describe-mouse-briefly (&optional repeat)
  60.   "Print a short message about what a mouse button does.  With REPEAT,
  61. keep accepting buttons and describing them until \\[keyboard-quit]."
  62.   (interactive "P")
  63.   (describe-mouse repeat t))
  64.  
  65. (defun describe-mouse (&optional repeat brief)
  66.   "Display documentation of the function(s) a mouse button invokes.  With
  67. REPEAT (prefix interactively), keep accepting buttons and describing them
  68. until \\[keyboard-quit].  With BRIEF, just make a short message."
  69.   (interactive "P")
  70.   (push-event 'button 'mouse::help-handler)
  71.   (unwind-protect
  72.       (let ((first t))
  73.     (while (or first repeat)
  74.       (let ((mouse-press-value nil)
  75.         (mouse-press-scr nil)
  76.         (mouse-press-wait t)
  77.         (echo-keystrokes 0))
  78.         (while mouse-press-wait
  79.           (if (or first (not brief))
  80.           (message (if brief "Describe mouse button briefly:"  "Describe mouse button:")))
  81.           (sit-for 1 t)
  82.           (if (input-pending-p)
  83.           (read-char)))
  84.         (message "")
  85.         (let* ((number (nth 3 mouse-press-value))
  86.            (modstate (nth 4 mouse-press-value))
  87.            (arg (epoch::coords-to-point (nth 1 mouse-press-value) (nth 2 mouse-press-value) mouse-press-scr))
  88.            (buffer (and arg (nth 1 arg)))
  89.            ;; Find which button table (window, mode, minibuf).
  90.            (number-offset (if (and (eq mouse-press-scr (minibuf-screen))
  91.                        (= (minibuffer-depth) 0))
  92.                       mouse-minibuf
  93.                     (if (null (car arg))
  94.                     mouse-mode
  95.                       0)))
  96.            (down-index (+ mouse-down
  97.                   (if (/= 0 (logand modstate shift-mod-mask)) mouse-shift 0)
  98.                   (if (/= 0 (logand modstate control-mod-mask)) mouse-control 0)
  99.                   (if (/= 0 (logand modstate meta-mod-mask)) mouse-meta 0)
  100.                   (* mouse::button-size (+ number number-offset -1))))
  101.            (up-index (+ (- down-index mouse-down) mouse-up))
  102.            (map (and arg (symbol-buffer-value 'mouse::local-map buffer)))
  103.            (down-defn (or (and (vectorp map) (aref map down-index))
  104.                   (aref mouse::global-map down-index)))
  105.            (up-defn (or (and (vectorp map) (aref map up-index))
  106.                 (aref mouse::global-map up-index))))
  107.           (if (and (or (null down-defn) (integerp down-defn))
  108.                (or (null up-defn) (integerp up-defn)))
  109.           (message "button is undefined")
  110.         (if brief
  111.             (message "DOWN: %s  UP: %s"
  112.                  (function-description down-defn)
  113.                  (function-description up-defn))
  114.           (with-output-to-temp-buffer "*Help*"
  115.             (if down-defn (progn
  116.                     (princ "DOWN - ")
  117.                     (prin1 down-defn)
  118.                     (princ ":\n")
  119.                     (if (documentation down-defn)
  120.                     (princ (documentation down-defn))
  121.                       (princ "not documented"))
  122.                     (princ "\n\n")))
  123.             (if up-defn (progn
  124.                   (princ "UP - ")
  125.                   (prin1 up-defn)
  126.                   (princ ":\n")
  127.                   (if (documentation up-defn)
  128.                       (princ (documentation up-defn))
  129.                     (princ "not documented"))))
  130.             (print-help-return-message))
  131.           (epoch::redisplay-screen))))
  132.         (setq first nil))))
  133.     (pop-event 'button)))
  134.  
  135. (defun mouse::help-handler (type value scr)
  136.   (setq mouse-press-value value
  137.     mouse-press-scr scr
  138.     mouse-press-wait (nth 0 value)))
  139. ;;; --------------------------------------------------------------------------
  140. ;;; Mouse-helper: a popup screen describing all mouse button combinations.
  141.  
  142. (defvar mouse-helper-screen nil "Screen for mouse-helper.")
  143. (defvar auto-unmap-screens nil)        ;just in case there isn't any.
  144. (defvar last-mouse-helper-mode 1)
  145. (defvar mouse-helper-mouse-map (create-mouse-map))
  146. (define-mouse mouse-helper-mouse-map mouse-mode-left mouse-down 'mouse-helper-mode-down)
  147. (define-mouse mouse-helper-mouse-map mouse-mode-left mouse-up 'mouse-helper-mode-up)
  148. (define-mouse mouse-helper-mouse-map mouse-left mouse-down (function (lambda (arg) (mapraised-screen))))
  149. (define-mouse mouse-helper-mouse-map mouse-left mouse-up t)
  150.  
  151. (defconst mouse-helper-keys (list "WINDOW-DOWN" "WINDOW-UP"
  152.                   "MODE-DOWN" "MODE-UP"
  153.                   "MINIBUF-DOWN" "MINIBUF-UP"))
  154. (defconst mouse-helper-modes (list "WINDOW   mode   minibuf      DOWN"
  155.                    "WINDOW   mode   minibuf"
  156.                    "window   MODE   minibuf      DOWN"
  157.                    "window   MODE   minibuf"
  158.                    "window   mode   MINIBUF      DOWN"
  159.                    "window   mode   MINIBUF"))
  160. (defconst mouse-helper-offsets (list (+ mouse-down (* mouse-window mouse::button-size))
  161.                      (+ mouse-up (* mouse-window mouse::button-size))
  162.                      (+ mouse-down (* mouse-mode mouse::button-size))
  163.                      (+ mouse-up (* mouse-mode mouse::button-size))
  164.                      (+ mouse-down (* mouse-minibuf mouse::button-size))
  165.                      (+ mouse-up (* mouse-minibuf mouse::button-size))))
  166.  
  167. (defun mouse-helper-mode-down (arg)
  168.   "Show bindings for down presses."
  169.   (mouse::set-point arg)
  170.   (let ((i (cond ((< mouse::x 7) 0)
  171.          ((< mouse::x 14) 2)
  172.          (4))))
  173.     (mouse-helper-show (elt mouse-helper-keys i))
  174.     (setq mode-line-format (elt mouse-helper-modes i))
  175.     (setq last-mouse-helper-mode i)))
  176.  
  177. (defun mouse-helper-mode-up (arg)
  178.   "Show bindings for up presses.  If dragged, leave down presses showing."
  179.   (if (/= mouse::clicks 0)
  180.       (progn (mouse::set-point arg)
  181.          (let ((i (cond ((< mouse::x 7) 1)
  182.                 ((< mouse::x 14) 3)
  183.                 (5))))
  184.            (mouse-helper-show (elt mouse-helper-keys i))
  185.            (setq mode-line-format (elt mouse-helper-modes i))
  186.            (setq last-mouse-helper-mode i)))))
  187.  
  188.  
  189. (defun mouse-helper (&optional force geometry font file)
  190.   "Map or unmap the mouse helper screen.  If the screen does not exist, it
  191. is created listing the various mouse functions.  With non-nil FORCE (prefix
  192. interactively), the screen is recreated and mapped regardless of whether it
  193. already exists.  By clicking on the mode line, the contents can be changed
  194. for window, mode, or minibuf bindings.  Down bindings are shown while the
  195. button is help down.  Up bindings are shown when the button is released.
  196. If there is no up binding, the corresponding down binding is shown with a
  197. `>' prefixed.  If FORCE is 'nomap, the helper screen is left unmapped.
  198. GEOMETRY and FONT are used to create the screen.  FILE has a listing of the
  199. text for the helper buffer.  In this file, keywords `WINDOW', `MODE', and
  200. 'MINIBUF' with suffixes `UP' and `DOWN' indicate the different sections.
  201. The associated section is enclosed by blank lines following the keyword.
  202. Without FILE, the helper text is built from the current global mouse
  203. bindings."
  204.   (interactive "P")
  205.   (if (and (screenp mouse-helper-screen)
  206.        (get-screen-id mouse-helper-screen))
  207.       (progn
  208.     (if (or (not (get-buffer " *mouse-helper*"))
  209.         (not (memq mouse-helper-screen (screens-of-buffer " *mouse-helper*"))))
  210.         (setq force (or force t)))
  211.     (if (or (eq force 'nomap)
  212.         (and (not force) (memq mouse-helper-screen (screen-list))))
  213.         (progn (unmap-screen mouse-helper-screen)
  214.            (setq auto-unmap-screens (delq 'mouse-helper-screen auto-unmap-screens)))
  215.       (mapraised-screen mouse-helper-screen)
  216.       (or (memq 'mouse-helper-screen auto-unmap-screens)
  217.           (setq auto-unmap-screens (append auto-unmap-screens (list 'mouse-helper-screen)))))))
  218.   (if (or force
  219.       (not (screenp mouse-helper-screen))
  220.       (not (get-screen-id mouse-helper-screen)))
  221.       (save-excursion
  222.     (set-buffer (get-buffer-create " *mouse-helper*"))
  223.     (erase-buffer)
  224.     (if (and (stringp file) (file-exists-p file))
  225.         (insert-file-contents file)
  226.       (let ((keys mouse-helper-keys)
  227.         (offsets mouse-helper-offsets)
  228.         (width (if geometry (string-to-int geometry) 100)))
  229.         (while keys
  230.           (insert "\n\n" (car keys) "\n\n")
  231.           (build-mouse-help mouse::global-map (car offsets) width)
  232.           (setq keys (cdr keys)
  233.             offsets (cdr offsets)))))
  234.     (mouse-helper-show (elt mouse-helper-keys last-mouse-helper-mode))
  235.     (setq mode-line-format (elt mouse-helper-modes last-mouse-helper-mode))
  236.     (use-local-mouse-map mouse-helper-mouse-map)))
  237.   (if (and (screenp mouse-helper-screen)
  238.        (get-screen-id mouse-helper-screen))
  239.       (set-window-buffer (epoch::selected-window mouse-helper-screen)
  240.              " *mouse-helper*")
  241.     (setq mouse-helper-screen
  242.       (create-screen " *mouse-helper*"
  243.              (screen-attributes (or geometry "100x9+250+-26") "MOUSE"
  244.                         (cons 'font (or font "5x8")))))
  245.     (if (eq force 'nomap)
  246.     (progn (unmap-screen mouse-helper-screen)
  247.            (setq auto-unmap-screens (delq 'mouse-helper-screen auto-unmap-screens)))
  248.       (or (memq 'mouse-helper-screen auto-unmap-screens)
  249.       (setq auto-unmap-screens (append auto-unmap-screens (list 'mouse-helper-screen)))))))
  250.  
  251. (defvar uninteresting-fncs (list 'mouse::set-point 'mouse-set-point
  252.                  'start-mouse-drag 'call-interactively
  253.                  'quote 'save-excursion 'set-buffer
  254.                  'nth  'undo-boundary 'setq))
  255.  
  256. (defun interesting-function (l)
  257.   "Return the first function mentioned in the list that is not in
  258. uninteresting-fncs."
  259.   (let ((f nil))
  260.     (while (and l (listp l)
  261.         (if (functionp f)
  262.             (memq f uninteresting-fncs)
  263.           t))
  264.       (setq f (car l))
  265.       (if (and f (listp f))
  266.       (setq f (interesting-function f)))
  267.       (setq l (cdr l)))
  268.     f))
  269.  
  270. (defun function-description (func &optional max)
  271.   "Return a string describing the function FUNC.  If it is a lambda list,
  272. any documentation string is used.  If there is no documentation string, the
  273. first function in the list that is not in uninteresting-fncs is used.
  274. With optional MAX, limits string to MAX characters."
  275.   (if (null func)
  276.       ""
  277.     (let ((s (if (functionp func)
  278.          (documentation func))))
  279.       (if (and (listp func)
  280.            (eq (car func) 'lambda))
  281.       (or s
  282.           (setq func (interesting-function func)))
  283.     (setq s nil))
  284.       (or s (setq s (format "%s" func)))
  285.       (substring s 0 (if max (min (length s) max))))))
  286.  
  287. (defconst mouse-helper-states-text (list "PLAIN" "CONTROL" "SHIFT" "META"
  288.                        "C-S" "M-C" "M-S" "M-C-S"))
  289. (defconst mouse-helper-states (list mouse-down mouse-control mouse-shift mouse-meta
  290.                       mouse-control-shift mouse-meta-control
  291.                       mouse-meta-shift mouse-meta-control-shift))
  292.  
  293. (defun build-mouse-help (map offset width)
  294.   "Build the mouse-helper text from bindings in MAP at OFFSET.  For any
  295. buttons with no binding on one edge, the other edge's entry is used (with a
  296. `>' prefixed).  WIDTH is the number of columns each line should fit in."
  297.   (let ((states mouse-helper-states)
  298.     (states-text mouse-helper-states-text)
  299.     entry)
  300.     (setq width (/ (- width 10) 3))
  301.     (while states
  302.       (insert (car states-text))
  303.       (indent-to 8 1)
  304.       (if (setq entry (aref map (+ (car states) (* mouse-left mouse::button-size) offset)))
  305.       (insert (function-description entry width))
  306.     (if (setq entry (aref map (logxor
  307.                    (+ (car states) (* mouse-left mouse::button-size) offset)
  308.                    mouse-up)))
  309.         (insert ?> (function-description entry (1- width)))))
  310.       (indent-to (+ 9 width) 1)
  311.       (if (setq entry (aref map (+ (car states) (* mouse-middle mouse::button-size) offset)))
  312.       (insert (function-description entry width))
  313.     (if (setq entry (aref map (logxor
  314.                    (+ (car states) (* mouse-middle mouse::button-size) offset)
  315.                    mouse-up)))
  316.         (insert ?> (function-description entry (1- width)))))
  317.       (indent-to (+ 10 width width) 1)
  318.       (if (setq entry (aref map (+ (car states) (* mouse-right mouse::button-size) offset)))
  319.       (insert (function-description entry width))
  320.     (if (setq entry (aref map (logxor
  321.                    (+ (car states) (* mouse-right mouse::button-size) offset)
  322.                    mouse-up)))
  323.         (insert ?>(function-description entry (1- width)))))
  324.       (insert ?\n)
  325.       (setq states (cdr states)
  326.         states-text (cdr states-text)))))
  327.  
  328. (defun mouse-helper-show (keyword)
  329.   "Narrow the mouse-helper buffer to text associated with regexp KEYWORD.
  330. Assumes mouse-helper buffer is selected."
  331.   (widen)
  332.   (goto-char (point-min))
  333.   (re-search-forward keyword)
  334.   (let ((beg (if (search-forward "\n\n" nil t)
  335.          (match-end 0) (point))))
  336.     (search-forward "\n\n" nil 'end)
  337.     (while (eq (preceding-char) ?\n)
  338.       (backward-char))
  339.     (narrow-to-region beg (point)))
  340.   (goto-char (point-min)))
  341.