home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / MouseAndMenuEmacs / term-menus.el < prev    next >
Encoding:
Text File  |  1990-05-31  |  14.8 KB  |  394 lines
  1. ;;; Pop-up menus for use on arbitrary terminal types.
  2. ;;; Similar in spirit (and functionality) to the mode-specific
  3. ;;; SUN menu interface described in 'sun-menus.el'.
  4. ;;; Russell A. Ritchie, Scottish HCI Centre, <russell@uk.ac.strath.hci>.
  5. ;;; Wed May  4 11:33:23 1988
  6.  
  7. (require 'electric)
  8. (require 'gensym)
  9. (require 'hci-menus)
  10. (provide 'term-menus)
  11.  
  12. ;;;; This part of the file deals with menu definition/creation, and
  13. ;;;; would be identical to that of the SUN menu functions, except that
  14. ;;;; we don't actually have a mouse...  Therefore it is necessary to
  15. ;;;; specify a key binding to be used to for the menu-pop-up, the
  16. ;;;; default is Meta-Control-m.  This finger-twister is the default
  17. ;;;; because the obvious choice (to me at any rate...), Meta-m, is
  18. ;;;; already bound by default.  I suppose you could use Control-c-m,
  19. ;;;; but Control-c is the user-prefix map, supposedly reserved for
  20. ;;;; user customisation, so it should be left alone.
  21.  
  22. (defvar term-menu-key "\e\C-m"
  23.   "*The keystroke that pop-up menus are to be bound to.")
  24.  
  25. (defvar term-menu-buffer-switch nil
  26.   "*If non-nil (default nil) replace key bindings of switch-to-buffer
  27. and switch-to-buffer-other-window with menu-based equivalents.")
  28.  
  29. ;;; The main function is set-mode-menu, e.g.
  30. ;;; (set-mode-menu MENU-NAME)
  31. ;;;     MENU-NAME is the function that defines the top-level menu,
  32.  
  33. ;;; To use this facility, insert lines like the following in your
  34. ;;; '.emacs' init file.
  35. ;;;     (setq lisp-mode-hook
  36. ;;;           (function (lambda ()
  37. ;;;               (require 'term-menus) 
  38. ;;;               (set-mode-menu 'lisp-menu))))
  39.  
  40. ;;; If you always load 'term-menus', by putting (require 'term-menus)
  41. ;;; in your '.emacs' init file, then this can be simplified into:
  42. ;;;    (setq lisp-mode-hook
  43. ;;;           (function (lambda ()
  44. ;;;              (set-mode-menu 'lisp-menu))))
  45.  
  46. ;;; To define your own menus, for customisation or to provide some
  47. ;;; that do not already exist, try:
  48. ;;;      (setq any-mode-hook
  49. ;;;             (function
  50. ;;;         (lambda ()
  51. ;;;           (defHCImenu Any-menu
  52. ;;;             ("Any Mode Menu name string")
  53. ;;;             ("Menu item label" fn-name arg1 arg2) ; This fn takes 2 args
  54. ;;;             ("Another Menu item label" another-fn-name) ; No args..
  55. ;;;             ("Walking Menu item" . Any-other-menu) ; A pull-right menu
  56. ;;;             ("Last Menu item" last-fn arg)) ; A fn of 1 arg.
  57. ;;;           (defHCImenu Any-other-menu
  58. ;;;             ;; Any-other-name has no name stripe...
  59. ;;;             ("Any other Menu item label" fn-name arg)
  60. ;;;             ("Any other Menu next item label" next-fn-name)
  61. ;;;             ("Any other Menu last item label" last-fn-name arg1 arg2 arg3))
  62. ;;;           (set-mode-menu 'Any-menu))))
  63.  
  64. ;;;; The first thing we need is a better interface for creating
  65. ;;;; interfaces, so...
  66.  
  67. (defun create-mode-term-menu-eval-function (mode-name mode-menu)
  68.   "Create an appropriate mode-menu-eval function for MODE-NAME with MODE-MENU.
  69. This is the function that is usually is called when a menu is requested in
  70. a MODE-NAME window. See also set-mode-terminal-menu."
  71.   (eval
  72.     (` (defun (, (make-symbol (format "%s-term-menu" mode-name))) ()
  73.      (, (format "Terminal Menu handler for %s." mode-name))
  74.      (interactive)
  75.      (term-menu-evaluate (selected-window) '(, mode-menu))))))
  76.  
  77. (defun set-mode-menu (menu)
  78.   "Set MENU to be the menu that pops up in the current major mode when 
  79. term-menu-key (default \"ESC RET\") is detected in the text-region."
  80.   (local-set-key term-menu-key
  81.          (create-mode-term-menu-eval-function major-mode menu))) 
  82.  
  83. (defun term-menu-init ()
  84.   "Initialise the top level term-menu, i.e. bind it to the value of term-menu-key."
  85.   (global-set-key term-menu-key 'emacs-term-menu))
  86.  
  87. (defun emacs-term-menu ()
  88.   "Standard vanilla term menu function for vanilla menu pop-up."
  89.   (interactive)
  90.   (term-menu-evaluate (selected-window) 'emacs-menu))
  91.  
  92. ;; Copied from 'sun-mouse.el', Fri May  6 16:47:53 1988
  93.     
  94. (defmacro eval-in-window (window &rest forms)
  95.   "Switch to WINDOW, evaluate FORMS, return to original window."
  96.   (` (let ((OriginallySelectedWindow (selected-window)))
  97.        (unwind-protect
  98.        (progn
  99.          (select-window (, window))
  100.          (,@ forms))
  101.      (select-window OriginallySelectedWindow)))))
  102.  
  103. (defun term-menu-evaluate (window menu)
  104.   "Create (or display) a pop-up menu from MENU menu description, 
  105. get a selection, and evaluate that in the context of WINDOW."
  106.   ;; This pops up a menu and sets term-menu-selected-item to be the choice.
  107.   (term-menu-selection (term-menu-buffer-create menu)) 
  108.   (and term-menu-selected-item    ; Only do this if there's something to do!
  109.        (if (eq term-menu-no-selection term-menu-selected-item)
  110.        ;; We want out...
  111.        term-menu-no-selection  
  112.      (eval                ; Do selection in window
  113.        (` (eval-in-window window (, term-menu-selected-item))))
  114.      (setq term-menu-selected-item nil)))) ; Flush selection
  115.  
  116. (defun term-menu-buffer-create (menu-name)
  117.   "Create a menu buffer for MENU-NAME."
  118.   (let ((menu-buffer (get-buffer-create (format "*%s*" menu-name))))
  119.     (set-buffer menu-buffer)
  120.     (term-menu-mode menu-name)
  121.     menu-buffer))
  122.       
  123. (defun term-menu-select-item (header items)
  124.   "Pop up a Menu with HEADER and ITEMS, return selected item or nil."
  125.   (let ((menu-symbol (gensym)))
  126.     (eval (append (if header
  127.               (list 'defHCImenu menu-symbol (list header))
  128.             (list 'defHCImenu menu-symbol))
  129.           (mapcar (function (lambda (x)
  130.                        (list (format "%s" x) 'identity x)))
  131.               items)))
  132.     (term-menu-selection (term-menu-buffer-create menu-symbol))
  133.     (makunbound menu-symbol)        ; Destroy the Temp Menu.
  134.     (if term-menu-selected-item    ; Only do this if there's something to do!
  135.     (if (eq term-menu-no-selection term-menu-selected-item)
  136.          ;; We want out...
  137.         (setq term-menu-selected-item nil)
  138.       (prog1            ; Flush selection-slot but eval and 
  139.           (eval term-menu-selected-item)    ; return what was selected.
  140.         (setq term-menu-selected-item nil))))))
  141.  
  142. (defun term-menu-select-emacs-buffer (&optional buffers header)
  143.   "Pop up a menu of BUFFERS (defaults to (buffer-list)).
  144. If optional 2nd arg HEADER is non-nil use that instead of 
  145. \"Select a buffer\" as the namestripe of the menu to be popped up.
  146. Return selected buffer or nil."
  147.   (let ((buf-list (or buffers (buffer-list)))
  148.     buf-a-list)
  149.     (while buf-list
  150.       (let ((elt (car buf-list)))
  151.     (if (not (string-match "^ " (buffer-name elt)))
  152.         (setq buf-a-list     
  153.           (cons (cons (format "%14s   %s"
  154.                       (buffer-name elt)
  155.                       (or (buffer-file-name elt) ""))
  156.                   elt)
  157.             buf-a-list))))
  158.       (setq buf-list (cdr buf-list)))
  159.     (setq buffers (reverse buf-a-list))
  160.     (cdr (assoc
  161.       (term-menu-select-item
  162.        (or header "Select a buffer") (mapcar 'car buffers))
  163.       buffers))))
  164.  
  165. (defun term-menu-switch-to-buffer ()
  166.   "Switch to a buffer selected via a menu."
  167.   (interactive)
  168.   (switch-to-buffer 
  169.    (or (term-menu-select-emacs-buffer nil "Switch to buffer:")
  170.        (current-buffer))))
  171.  
  172. (defun term-menu-switch-to-buffer-other-window ()
  173.   "Switch to a buffer in another window selected via a menu."
  174.   (interactive)
  175.   (switch-to-buffer-other-window
  176.    (or (term-menu-select-emacs-buffer nil "Switch to buffer in other window:")
  177.        (current-buffer))))
  178.  
  179. (if term-menu-buffer-switch
  180.     (progn
  181.       (mapcar
  182.        (function (lambda (key)
  183.            (global-set-key key 'term-menu-switch-to-buffer)))
  184.        (where-is-internal 'switch-to-buffer))
  185.       (mapcar
  186.        (function (lambda (key)
  187.            (global-set-key key 'term-menu-switch-to-buffer-other-window)))
  188.        (where-is-internal 'switch-to-buffer-other-window))))
  189.  
  190. ;;; Term menu mode
  191.  
  192. (defvar term-menu-mode-map nil
  193.   "The mode map for term-menu buffers.")
  194.  
  195. (if term-menu-mode-map
  196.     nil
  197.   (setq term-menu-mode-map (make-keymap))
  198.   (setq term-menu-mode-esc-map (make-keymap))
  199.   (suppress-keymap term-menu-mode-map t)
  200.   (suppress-keymap term-menu-mode-esc-map t)
  201.   (fillarray term-menu-mode-map 'term-menu-quit) ; Back to previous menu.
  202.   (fillarray term-menu-mode-esc-map 'term-menu-quit)
  203.   (define-key term-menu-mode-map "\e" term-menu-mode-esc-map)
  204.   (define-key term-menu-mode-map " " 'term-menu-select)
  205.   (define-key term-menu-mode-map "q" 'term-menu-noselect) ; Quit from submenus.
  206.   (define-key term-menu-mode-map "\C-g" 'term-menu-noselect)
  207.   (define-key term-menu-mode-map "\C-z" 'suspend-emacs)
  208.   (define-key term-menu-mode-map "\C-h" 'Helper-help)
  209.   (define-key term-menu-mode-map "?" 'Helper-describe-bindings)
  210.   (define-key term-menu-mode-map "l" 'term-menu-scroll-down)
  211.   (define-key term-menu-mode-map "" 'term-menu-scroll-down)
  212.   (define-key term-menu-mode-esc-map "v" 'term-menu-scroll-down)
  213.   (define-key term-menu-mode-map "n" 'term-menu-scroll-up)
  214.   (define-key term-menu-mode-map "\C-v" 'term-menu-scroll-up)
  215.   (define-key term-menu-mode-map "u" 'term-menu-previous-line)
  216.   (define-key term-menu-mode-map "\C-p" 'term-menu-previous-line)
  217.   (define-key term-menu-mode-map "d" 'term-menu-next-line)
  218.   (define-key term-menu-mode-map "\C-n" 'term-menu-next-line))
  219.  
  220. (defvar term-menu-items ()
  221.   "Where the menu-option-label . functions-to-be-called pairs are stashed.")
  222.  
  223. (defvar term-menu-selected-item ()
  224.   "The form to be evaluated from the selected menu item")
  225.  
  226. (defvar term-menu-no-selection (make-temp-name "No-selection")
  227.   "A unique name for the no-selection selection.")
  228.  
  229. ;; Term menu mode is only suitable for specially formatted data.
  230. (put 'term-menu-mode 'mode-class 'special)
  231.  
  232. (defmacro pullrightp (menu-item)
  233.   (` (atom (cdr (, menu-item)))))
  234.  
  235. (defun term-menu-mode (name)
  236.   "Major mode for term menus.
  237. Arg NAME is the menu to be displayed."
  238.   (kill-all-local-variables)
  239.   (use-local-map term-menu-mode-map)
  240.   (let* ((menu-body (symbol-value name))
  241.      (menu-name-suppliedp (null (cdr (car menu-body))))
  242.      (menu-name (if menu-name-suppliedp (car (car menu-body)) ""))
  243.      (menu-items (if menu-name-suppliedp (cdr menu-body) menu-body))
  244.      (menu-item-counter 1)
  245.      (menu-key-reminders (or (get name 'pretty-key-reminders)
  246.                  (term-menu-pretty-key-reminders
  247.                   name
  248.                   (if menu-name-suppliedp
  249.                       (cdr (get name 'key-reminders))
  250.                     (get name 'key-reminders))))))
  251.     ;; Record the commands for this buffer..
  252.     (make-local-variable 'term-menu-items)
  253.     (setq term-menu-items menu-items)
  254.     (setq mode-line-buffer-identification menu-name)
  255.     (setq mode-name "Menu Mode")
  256.     ;; Set up distinctive mode line.
  257.     (setq mode-line-format
  258.       (list "        "
  259.         mode-line-buffer-identification
  260.         "       [%[" mode-name "]%]    [" global-mode-string "]        "
  261.         (cons -3 "%p")))
  262.     (while menu-items
  263.       ;; Insert the options in the buffer.
  264.       (insert (format "%d:    %s" menu-item-counter (car (car menu-items))))
  265.       (if (not inhibit-key-reminders)
  266.       (let ((key-reminder (car menu-key-reminders)))
  267.         (if key-reminder
  268.         (insert (format "    [%s]" key-reminder)))))
  269.       (if (pullrightp (car menu-items))
  270.       (insert "    =>"))
  271.       (insert "\n")
  272.       (setq menu-item-counter (1+ menu-item-counter))
  273.       (setq menu-items (cdr menu-items))
  274.       (setq menu-key-reminders (cdr menu-key-reminders)))
  275.     (make-local-variable 'Helper-return-blurb)
  276.     (setq Helper-return-blurb
  277.       (format "return to the %s." (if menu-name-suppliedp
  278.                       menu-name
  279.                     "previous menu")))
  280.     (setq truncate-lines t)
  281.     (delete-char -1)            ; remove final newline.
  282.     (goto-char (point-min))
  283.     (delete-matching-lines "^$")    ; delete any spurious blank ones.
  284.     (setq buffer-read-only t)
  285.     (setq major-mode 'term-menu-mode)
  286.     (run-hooks 'term-menu-mode-hook)))
  287.  
  288. (defun term-menu-pretty-key-reminders (menu reminders)
  289.   "Make all key REMINDERS 'pretty' descriptions."
  290.   (put menu 'pretty-key-reminders
  291.        (mapcar (function (lambda (keys)
  292.                (if keys
  293.                    (mapconcat 'key-description keys " or "))))
  294.            reminders)))
  295.  
  296. (defun term-menu-selection (menu-buffer)
  297.   "Pop up the MENU-BUFFER electric term-menu buffer.
  298. Return the function associated with the menu option selected (nil if none)."
  299.   (save-excursion
  300.     (save-window-excursion
  301.       (let ((buffer (window-buffer (Electric-pop-up-window menu-buffer))))
  302.     (unwind-protect
  303.         (progn
  304.           (set-buffer buffer)
  305.           ;; When term-menu-exit is thrown, term-menu-selected-item
  306.           ;; will have been set to the s-expression to be evaluated, or to
  307.           ;; the special value term-menu-no-selection, indicating that
  308.           ;; immediate exit from submenus is desired.
  309.           (catch 'term-menu-exit
  310.         (Electric-command-loop
  311.           'term-menu-exit
  312.           "u-up d-down n-next page l-last page SPC-select q-quit others-prev menu (if any)"
  313.           t))))
  314.     (kill-buffer buffer)
  315.     (message ""))))
  316.   term-menu-selected-item)        ; which should now be set...
  317.  
  318. (defun term-menu-index ()
  319.   "Return the index of the term menu item listed by this line of the term menu."
  320.   (1+ (count-lines 1 (point))))
  321.  
  322. (defun term-menu-get-selection ()
  323.   "Set term-menu-selected-item to be the function associated with the menu selection at point."
  324.   (if (not (looking-at "$"))
  325.       (let ((menu-item (nth (1- (term-menu-index)) term-menu-items)))
  326.     (setq term-menu-selected-item
  327.           (if (pullrightp menu-item)
  328.           ;; a pullright menu - pull it and get a selection from it
  329.           (term-menu-selection
  330.            (eval (` (term-menu-buffer-create '(, (cdr menu-item))))))
  331.         (cdr menu-item))))
  332.     ;; On a blank line, there is no selection here
  333.     (error "There is no menu option on this line.")))
  334.  
  335. (defun term-menu-select ()
  336.   "If term-menu-selected-item is set, throw out of Electric-command-loop
  337. Kill buffer if quit given."
  338.   (interactive)
  339.   (setq unread-command-char -1)
  340.   (condition-case ()
  341.       (term-menu-get-selection)    ; Get a selection.
  342.     (error 
  343.       (setq term-menu-selected-item nil) ; Flush any dummy selections.
  344.       (goto-char (point-min))))
  345.   (condition-case ()
  346.       ;; Only quit when a selection is made.
  347.       (and term-menu-selected-item (throw 'term-menu-exit nil))
  348.     (error
  349.       (setq term-menu-selected-item nil) ; Flush last selection
  350.       (kill-buffer (current-buffer)))))
  351.  
  352. (defun term-menu-quit ()
  353.   "Throw out of Electric-command-loop, kill buffer if quit given."
  354.   (interactive)
  355.   (setq unread-command-char -1)
  356.   (setq term-menu-selected-item nil) ; Flush last selection
  357.   (condition-case ()
  358.       (throw 'term-menu-exit nil)
  359.     (error
  360.       (kill-buffer (current-buffer)))))
  361.   
  362. (defun term-menu-noselect ()
  363.   "Signal direct quit from submenus."
  364.   (interactive)
  365.   (setq unread-command-char -1)
  366.   (setq term-menu-selected-item term-menu-no-selection)
  367.   (condition-case ()
  368.       (throw 'term-menu-exit nil)
  369.     (error
  370.       (kill-buffer (current-buffer)))))
  371.  
  372. (defun term-menu-next-line ()
  373.   "Move the beginning of the next line, if already at eob go to beginning of current line."
  374.   (interactive)
  375.   (end-of-line 2)
  376.   (beginning-of-line))
  377.  
  378. (defun term-menu-previous-line ()
  379.   "Move to previous line, if already at bob go to beginning of current line."
  380.   (interactive)
  381.   (beginning-of-line 0))
  382.  
  383. (defun term-menu-scroll-down ()
  384.   "Scroll the menu up a page if it's not all visible."
  385.   (interactive)
  386.   (if (not (pos-visible-in-window-p (point-min)))
  387.       (scroll-down nil)))
  388.  
  389. (defun term-menu-scroll-up ()
  390.   "Scroll the menu down a page if it's not already all visible."
  391.   (interactive)
  392.   (if (not (pos-visible-in-window-p (point-max)))
  393.       (scroll-up nil)))
  394.