home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / MouseAndMenuEmacs / sun-menus.el < prev    next >
Encoding:
Text File  |  1990-05-31  |  13.3 KB  |  350 lines
  1. ;;; SunView interface to the hci-menus package; provides pop-up and
  2. ;;; pull-right menus for the SunView window system.
  3.  
  4. ;;; Russell Ritchie, Scottish HCI Centre, <russell@uk.ac.strath.hci>.
  5. ;;; Tue Mar 21 17:43:14 1989 
  6.  
  7. (require 'sun-fns)
  8. (require 'hci-menus)
  9. (provide 'sun-menus)
  10.  
  11. ;;; The main function is set-mode-menu, e.g.
  12. ;;;     (set-mode-menu MENU-NAME)
  13. ;;; MENU-NAME is the top-level menu.  To use this facility, insert
  14. ;;; lines like the following in your '.emacs' init.  file.
  15. ;;;     (setq lisp-mode-hook
  16. ;;;           (function (lambda ()
  17. ;;;              (require 'lisp-menus)
  18. ;;;              (set-mode-menu 'lisp-menu))))
  19.  
  20. ;;; To define your own menus, for customisation or to provide some
  21. ;;; that do not already exist, try:
  22. ;;;      (setq any-mode-hook
  23. ;;;             (function
  24. ;;;         (lambda ()
  25. ;;;           (defHCImenu Any-menu
  26. ;;;             ("Any Mode Menu name string")
  27. ;;;             ("Menu item label" fn-name arg1 arg2)
  28. ;;;             ("Another Menu item label" another-fn-name)
  29. ;;;             ("Walking Menu item" . Any-other-menu)
  30. ;;;             ("Last Menu item" last-fn arg))
  31. ;;;           (defHCImenu Any-other-menu
  32. ;;;             ;; Other-name has no name stripe...
  33. ;;;             ("Other Menu item label" fn-name arg)
  34. ;;;             ("Other Menu next label" next-fn-name)
  35. ;;;             ("Other Menu last label" last-fn-name arg1 arg2 arg3))
  36. ;;;               (set-mode-menu 'Any-menu))))
  37.   
  38. (defvar sun-menu-mouse-binding '(right text)
  39.   "*The mouse binding that the pop-up menu function is bound to.")
  40.  
  41. (defvar make-menus-silently nil
  42.   "*If non-nil (default nil) no messages will be printed as menus are made.")
  43.  
  44. (defvar sun-keyboard-prefix-binding "C-x *"
  45.   "The 'pretty' description of the key sequence the sun key map is bound to.")
  46.  
  47. (defvar sun-keyboard-translate-table
  48.   '(("a" . "1") ("b" . "2") ("c" . "3") ("d" . "4") ("e" . "5") ("f" . "6")
  49.     ("g" . "7") ("h" . "8") ("i" . "9") ("j" . "10") ("k" . "11")
  50.     ("l" . "12") ("m" . "13") ("n" . "14") ("o" . "15"))
  51.   "Maps key sequences of the form {a,b,c,d,e,f,g,h,i,j,k,l,m,n,o} to the
  52. appropriate 'pretty' key description, e.g. \"c\" => \"3\".
  53. The remaining characters determine which keypad and what modifiers were used.")
  54.  
  55. (defvar sun-keyboard-modifier-translate-table
  56.   '(("l" . "L")         ("t" . "F")         ("r" . "R")
  57.     ("L" . "Shift-L")        ("T" . "Shift-F")        ("R" . "Shift-R")
  58.     ("," . "C-L")        ("4" . "C-F")        ("2" . "C-R")
  59.     ("M-l" . "M-L")        ("M-t" . "M-F")        ("M-r" . "M-R")
  60.     ("C-l" . "C-Shift-l")   ("C-t" . "C-Shift-F")   ("C-r" . "C-Shift-R")
  61.     ("M-L" . "M-Shift-L")   ("M-T" . "M-Shift-F")   ("M-R" . "M-Shift-R")
  62.     ("M-," . "M-C-L")         ("M-4" . "M-C-F")        ("M-2" . "M-C-R")
  63.     ("M- " . "M-C-Shift-L")("M-" . "M-C-Shift-F")("M-" . "M-C-Shift-R"))
  64.   "Maps final substrings of a keypad keybinding to the appropriate modifiers.")
  65.  
  66. (defun sun-init ()
  67.   "Set up Emacstool window, if you know you are in an emacstool."
  68.   (define-key ctl-x-map "\C-@" 'sun-mouse-handler)
  69.   (if (< (sun-window-init) 0)
  70.       (message "Not running under Emacstool")
  71.     (mapcar (function (lambda (key) (global-set-key key 'suspend-emacstool)))
  72.         (where-is-internal 'suspend-emacs))
  73.     (substitute-key-definition 'suspend-emacs 'suspend-emacstool current-global-mousemap)
  74.     (substitute-key-definition 'suspend-emacs 'suspend-emacstool current-local-mousemap)
  75.     (if (not (or (equal sun-menu-mouse-binding '(right text))
  76.          (equal sun-menu-mouse-binding '(text right))))
  77.     ;; Remove default binding of emacs-menu-eval, and insert preferred binding.
  78.     (progn
  79.       (substitute-key-definition 'emacs-menu-eval 'ignore current-global-mousemap)
  80.       (global-set-mouse sun-menu-mouse-binding 'emacs-menu-eval)
  81.       ;; Selection is done using right mouse button, this is the
  82.       ;; default for popping the menu up. We only need say this if
  83.       ;; the default  sun-menu-mouse-binding  has been overridden.  
  84.       (message "Select menu options using the right mouse button.")))))
  85.  
  86. (defun create-mode-menu-eval-function (mode-name mode-menu)
  87.   "Create an appropriate mode-menu-eval function for MODE-NAME with
  88. MODE-MENU. This is the function that is usually is called when  
  89. sun-menu-mouse-binding  occurs in a MODE-NAME window. 
  90. See also set-mode-menu.  
  91. This function is used by set-mode-menu, and not intended to be user-callable.  
  92.  
  93. If you have more than 1 window on the screen, in differing modes, a potential
  94. problem exists since most functions operate on the buffer point is in, 
  95. not the buffer the mouse is in. To avoid real consistency problems (and confusion) 
  96. if point and mouse are not in the same window, point is put into the same window 
  97. as the mouse before the menu pops up." 
  98.   (eval
  99.    (` (defun
  100.     (, (intern (format "%s-menu-eval" mode-name)))
  101.     (window x y)
  102.     (, (format "Menu evaluation handler for %s." mode-name))
  103.     (interactive)
  104.     (if (not (eq (selected-window) window))
  105.         (progn            ; Ensure cursor movement seen.
  106.           (message "Moving to mouse window.")
  107.           (select-window window)
  108.           (message "")))
  109.     (sun-menu-evaluate
  110.      (selected-window) (1+ x) (1- y) (sun-make-menu '(, mode-menu)))))))
  111.  
  112. (defun sun-make-menu (menu)
  113.   "Make an internal SUN menu from MENU."
  114.   (let ((internal-representation
  115.      (get menu (if inhibit-key-reminders 'sun-menu 'sun-menu-reminding))))
  116.     (or internal-representation
  117.     (prog2
  118.      ;; Explain why the machine appears to have tripped up (or not)...
  119.      (if (not make-menus-silently)
  120.          (message "Making SUN Menu %s" menu))
  121.      (if inhibit-key-reminders
  122.          (put menu 'sun-menu
  123.           (eval
  124.            (cons 'defmenu
  125.              (cons (intern (format "%s-internal" menu))
  126.                    (mapcar (function
  127.                     (lambda (item)
  128.                       (let ((thing (cdr item)))
  129.                         (if (and thing 
  130.                              (symbolp thing)
  131.                              (menu-p thing))
  132.                         (cons (car item) 
  133.                               (sun-make-menu thing))
  134.                           item))))
  135.                        (symbol-value menu))))))
  136.        (put menu 'sun-menu-reminding
  137.         (eval (cons 'defmenu
  138.                 (cons (intern (format "%s-reminding-internal" menu))
  139.                   (sun-display-keybindings menu))))))
  140.      (if (not make-menus-silently)
  141.          (message "Making SUN Menu %s...done" menu))))))
  142.  
  143. (defun sun-display-keybindings (menu)
  144.   "Return MENU with key bindings for commands added to the
  145. end of the menu item if the command is bound to a key."
  146.   (or (get menu 'reminding-menu-items)
  147.       (let ((keybindings (cons 'dummy (sun-translate-keybindings menu)))
  148.         (body (symbol-value menu)))
  149.     (put menu 'reminding-menu-items
  150.          (mapcar 
  151.           (function 
  152.            (lambda (menu-item)
  153.          ;; Wish mapcar would take an arbitrary number of sequences.
  154.          (setq keybindings (cdr keybindings))
  155.          (cons (let ((bindings (car keybindings)))
  156.              (if bindings
  157.                  (format "%s [%s]" (car menu-item) bindings)
  158.                (car menu-item)))
  159.                (let ((action (cdr menu-item)))
  160.              (if (and action (symbolp action) (menu-p action))
  161.                  (sun-make-menu action)
  162.                action)))))
  163.           body)))))
  164.  
  165. (defun sun-translate-keybindings (menu)
  166.   "Return a list of the correct pretty key description for all keybindings in
  167. MENU, using sun-keyboard-translate-table."
  168.   (or (get menu 'sun-keyboard-translated)
  169.       (let ((key-reminders (get menu 'key-reminders)))
  170.     (put menu 'sun-keyboard-translated
  171.          (mapcar
  172.           (function
  173.            (lambda (keys)
  174.          (if keys
  175.              (mapconcat 'sun-key-description keys " or "))))
  176.           key-reminders)))))
  177.  
  178. (defun sun-key-description (keystroke)
  179.   "Return a 'pretty' description of a SUN keyboard keystroke."
  180.   (let* ((prefix-length (length sun-keyboard-prefix-binding))
  181.      (pretty-key (key-description keystroke))
  182.      (sun-keyboard-prefixp
  183.       (and (> (length pretty-key) prefix-length)
  184.            (string= sun-keyboard-prefix-binding
  185.             (substring pretty-key 0 prefix-length)))))
  186.     (if sun-keyboard-prefixp
  187.     (let ((modifier    (cdr (assoc (substring pretty-key (+ prefix-length 3))
  188.                     sun-keyboard-modifier-translate-table)))
  189.           (number (cdr (assoc (substring
  190.                    pretty-key (1+ prefix-length) (+ prefix-length 2))
  191.                   sun-keyboard-translate-table))))
  192.       (if (and modifier number)
  193.           (concat modifier number)
  194.         pretty-key))
  195.       pretty-key)))
  196.  
  197. (defun set-mode-menu (menu)
  198.   "Set the menu that pops up in the current major mode, when the mouse
  199. event specified by sun-menu-mouse-binding, occurs to be MENU. 
  200.  
  201. If the first item in a pull-right menu is NOT a name stripe, then
  202. selecting the pull-right menu item in the parent will execute it
  203. without having to explicitly pull the menu, i.e. the default action of
  204. pull-right menus without name stripes is the action performed by the
  205. first item in the menu. Actually this is true of menus with
  206. namestripes as well, but namestripes are indicated to the evaluator by
  207. having a null action, so a null action is what is performed..."
  208.   (interactive)
  209.   (local-set-mouse
  210.     sun-menu-mouse-binding (create-mode-menu-eval-function major-mode menu)))
  211.  
  212. (defun emacs-menu-eval (window x y)
  213.   "Replaces standard supplied function with one that changes the 
  214. selected window to be the one the mouse is in before menu pop-up."
  215.   (interactive)
  216.   (if (not (eq (selected-window) window))
  217.       (progn                ; Ensure cursor movement is seen.
  218.     (message "Moving to mouse window.")
  219.     (select-window window)
  220.     (message "")))
  221.   (sun-menu-evaluate
  222.    (selected-window) (1+ x) (1- y) (sun-make-menu 'emacs-menu)))
  223.  
  224. (defun minibuffer-menu-eval (window x y)
  225.   "Pop-up menu of minibuffer commands."
  226.   (sun-menu-evaluate window x (1- y) (sun-make-menu 'minibuffer-menu)))
  227.  
  228. (defun sun-menu-other-menu-display (menu &optional w x y)
  229.   "Display MENU in window W at position (X,Y).  W, X and Y are optional,
  230. defaulting to *menu-window* (1+ *menu-x*) (1+ *menu-y*)
  231.  
  232.    This to allow menus to pop up menus as an alternative to
  233.    pull-rights.  It also enables recursive, multiply-inheritant menu
  234.    structures to be created, and as such should be used with extreme
  235.    care (or with a Path Algebra Tool)."
  236.   (let ((w (or w *menu-window*))
  237.     (x (or x *menu-x*))
  238.     (y (or y *menu-y*)))
  239.     (sun-menu-evaluate w x y (sun-make-menu menu))))
  240.  
  241. (defun sun-set-namestripe (string)
  242.   "Set the namestripe of the current 'suntools' window to be STRING."
  243.   (send-string-to-terminal (format "\033]l%s\033\\" string)))
  244.  
  245. (defun sun-menu-banner ()
  246.   "Display how to get menus in the namestripe."
  247.   (let* ((menu-binding (copy-alist sun-menu-mouse-binding))
  248.      (region (cond ((member 'text menu-binding)
  249.             (setq menu-binding (delq 'text menu-binding))
  250.             'text)
  251.                ((member 'modeline menu-binding)
  252.             (setq menu-binding (delq 'modeline menu-binding))
  253.             'modeline)
  254.                ((member 'scrollbar menu-binding)
  255.             (setq menu-binding (delq 'scrollbar menu-binding))
  256.             'scrollbar)
  257.                ((member 'minibuffer menu-binding)
  258.             (setq menu-binding (delq 'minibuffer menu-binding))
  259.             'minibuffer)
  260.                (t (error
  261.                "Menu pop-up function not bound to an existing region: %s"
  262.                sun-menu-mouse-binding))))
  263.      (button (cond ((member 'left menu-binding)
  264.             (setq menu-binding (delq 'left menu-binding))
  265.             'Left)
  266.                ((member 'middle menu-binding)
  267.             (setq menu-binding (delq 'middle menu-binding))
  268.             'Middle)
  269.                ((member 'right menu-binding)
  270.             (setq menu-binding (delq 'right menu-binding))
  271.             'Right)
  272.                (t (error
  273.                "Menu pop-up function not bound to an existing button: %s"
  274.                sun-menu-mouse-binding))))
  275.      (keys menu-binding))        ; Key modifiers (if any) are what's left.
  276.   (sun-set-namestripe
  277.    (format
  278.     "Scottish HCI Centre Emacs Listener [Hit %s%s-mouse in the %s region for Menus]"
  279.     (if keys
  280.     (concat (mapconcat
  281.          (function (lambda (key) (capitalize (symbol-name key))))
  282.          keys "-")
  283.         "-")
  284.       "")
  285.     button
  286.     region))))
  287.  
  288. ;;; SUNs minibuffer menu is bugged, it calls SUSPEND-EMACS not
  289. ;;; SUSPEND-EMACSTOOL, so... Might as well chrome it now too.
  290. ;;; Russell, Wed Jun 29 16:02:03 1988.
  291.  
  292. (defHCImenu minibuffer-menu
  293.   ("Minibuffer" message "Some miscellanous minibuffer commands.")
  294.   ("Stuff" sun-yank-selection)
  295.   ("Do-It"
  296.    if (minibuffer-window-p (selected-window))
  297.    (exit-minibuffer)
  298.    (error "There is no minibuffer command to do."))
  299.   ("Close Emacstool" suspend-emacstool))
  300.  
  301. ;;; Redefine the default and help menus. 
  302.  
  303. (defHCImenu help-describe-menu
  304.   ("bindings" describe-bindings)
  305.   ("mouse bindings" describe-mouse-bindings)
  306.   ("mouse briefly" call-interactively 'describe-mouse-briefly)
  307.   ("key" call-interactively 'describe-key)
  308.   ("key briefly" call-interactively 'describe-key-briefly)
  309.   ("function" call-interactively 'describe-function)
  310.   ("variable" call-interactively 'describe-variable)
  311.   ("mode" describe-mode)
  312.   ("syntax" describe-syntax))
  313.  
  314. ;; Mouse-help-menu is defined using the standard ``defmenu'' macro.
  315. ;; This does not save its contents effectively, so we recreate it
  316. ;; using ``defHCImenu''.
  317.  
  318. (defHCImenu mouse-help-menu
  319.   ("Text Region"
  320.    mouse-help-region *menu-window* *menu-x* *menu-y* 'text)
  321.   ("Scrollbar"
  322.    mouse-help-region *menu-window* *menu-x* *menu-y* 'scrollbar)
  323.   ("Modeline"
  324.    mouse-help-region *menu-window* *menu-x* *menu-y* 'modeline)
  325.   ("Minibuffer"
  326.    mouse-help-region *menu-window* *menu-x* *menu-y* 'minibuffer))
  327.  
  328. (defHCImenu help-menu
  329.   ("Help Menu")
  330.   ("Command apropos" call-interactively 'command-apropos)
  331.   ("Describe" . help-describe-menu)
  332.   ("Tutorial help" help-with-tutorial)
  333.   ("Mouse help" . mouse-help-menu)
  334.   ("View lossage" view-lossage)
  335.   ("Info" info))
  336.  
  337. (defHCImenu emacs-quit-menu
  338.   ("Close Emacstool" suspend-emacstool)
  339.   ("Quit" save-buffers-kill-emacs))
  340.  
  341. (defHCImenu emacs-menu
  342.   ("Emacs Menu")
  343.   ("Undo" call-interactively 'undo)
  344.   ("Stuff selection" sun-yank-selection)
  345.   ("Select region" call-interactively 'sun-select-region)
  346.   ("Find file" . find-file-menu)
  347.   ("New buffer" . new-buffer-mode-menu)
  348.   ("Help menu" . help-menu)
  349.   ("Quit" . emacs-quit-menu))
  350.