InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/elisp/interfaces/simple-menu2.el

Text File | 1991-06-10 | 23.8 KB | 606 lines

;;; Simple Menu Enhancements for GNU Emacs
;;;
;;; Version 1.1
;;; 6-5-91 - added ability to show esc-x commands in help
;;; 5-27-91 - added ability to show esc-x commands after command completion
;;; 2 may 91 added (require 'cl) reported by [e-mail],
;;;          [e-mail] (Halvorson,Peter J) & others
;;;
;;; COPYRIGHT and WARNINGS
;;;
;;; GNU Emacs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY.  No author or distributor
;;; accepts responsibility to anyone for the consequences of using it
;;; or for whether it serves any particular purpose or works at all,
;;; unless he says so in writing.  Refer to the GNU Emacs General Public
;;; License for full details.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; GNU Emacs, but only under the conditions described in the
;;; GNU Emacs General Public License.   A copy of this license is
;;; supposed to have been given to you along with GNU Emacs so you
;;; can know your rights and responsibilities.  It should be in a
;;; file named COPYING.  Among other things, the copyright notice
;;; and this notice must be preserved on all copies.
;;;
;;; Copyright (C) 1991 Frank Ritter.  Same license as above.
;;; Updated versions (if any) are available from the author or via ftp:
;;; from the elisp archive on tut.cis.ohio-state.edu as file
;;;  pub/gnu/emacs/elisp-archive/interfaces/simple-menu2.el.Z
;;;
;;; Initially based on code posted by Chris Ward.
;;;        Texas Instruments
;;;        ([e-mail])       [phone]
;;;        (X.400: /ADMD=MCI/PRMD=TI/C=US/G=Chris/S=Ward MCI_Mail_ID #4418566)
;;; and posted comments on Chris's code by Erik Hennum ([e-mail])
;;;
;;;    OVERVIEW/INTRODUCTION
;;;
;;; Simple-menu is a way to provide simple menus, rather reminiscent of
;;; the menus provided by the PDP software of McClellend & Rumelhart.  With
;;; the simple menus defined here for gnu-emacs, an initial menu of
;;; commands is displayed in the message line by calling run-menu on a
;;; previously defined menu.  The user types the first letter of an item to
;;; select it, and a command gets executed, or a sub-menu is entered.
;;; Often you will bind the top menu call to a key.
;;;
;;; The prompt that is displayed includes a reminder that help is available
;;; by typing ``?''.  (Help is also available by typing ^h or SPC.)
;;;
;;; Simple menus are defined with def-menu.  This takes a menu-name, an
;;; title, an intro help comment (ie.: "Pick a command"), and a list of
;;; items to be put on the menu.  Each  menu item is a list with 2
;;; components: 1) a display string, and 2) the command corresponding
;;; to the string.  The first word is put in the menu, the first letter in
;;; the string is used as the selector for the item (case insensitive),
;;; and the whole string is used in the help display.
;;; Def-menu and sm-add-to-menu allow you add commands to menus after they have
;;; been created.
;;;
;;; For example, the menu item:
;;;
;;; ("Redraw         Redraw the screen."   recenter)
;;;
;;; would create the item Redraw in the menu, and the letter R would
;;; select it.  In the help display, the full string would appear, along
;;; with any keybindings for the command in the local buffer, in this case
;;; the help line would look like
;;;
;;; Redraw         Redraw the screen. (C-l)
;;;
;;; The command given as the second argument can be either: 1) a simple
;;; function name, 2) a list to eval, or 3) a menu name (symbol).  If you
;;; want two commands there, wrap them in a progn because the internals of
;;; the program use each list position.
;;;
;;; If there is only one menu item, it is executed when the menu is run.
;;; After an item is selected and sucessfully completed, a possible keybinding
;;; or call via meta-X is displayed if possible.
;;;
;;;  Here's an example:
;;;
;;; (def-menu simple-menu
;;;   "Choose a simple command"
;;;   "Here are some simple commands to choose"
;;;  (("Add 2 + 2      Add 2+2 and print it out for me."
;;;    (progn (message (format "The Answer is %s." (+ 2 2)))
;;;           (sleep-for 2)))
;;;   ("Redraw         Redraw the screen." recenter)
;;;   ("Simple menu    Recurse and run this darn menu again." simple-menu)))
;;;
;;; Run-menu will start up the menu.  ^g will abort the menu.
;;; eg.
;;; (run-menu 'simple-menu)
;;; Binding this to a key makes the menu more usable.
;;;

(require 'cl)
(provide 'simple-menu)


;;;
;;;     I.    Variables and constants
;;;

;; uses main help buffer, used to be *MENU Help*
(defconst help-buffer "*Help*")

(defconst simple-menu-help-string "(?):")

(defconst sm-default-help-header "Commands in the")
(defconst sm-default-help-for-help
  "? or ^h or space to display this text at the first prompt.")
(defconst sm-default-help-footer "^G or space-bar to quit this menu now.
 First letter of the line to choose a command.")
(defconst CR "
")

; menus have the following fields:
;  prompt - the string used as the prompt before the choices
;  full-prompt - the string put in the message line
;  items - the list of items
;  prompt-header  -
;  help-header - header for the help buffer


;;;
;;;     II.    Creating functions
;;;
;; menus are symbols,
;; the raw items are stored under the plist 'items
;; the list that is displayed is stored in their value,
;;    it is made by calling sm-menu-ized-items on the items,
;; the prompt-header is under the 'prompt-header property
;; the help-header   is under the 'help-header prop.


(defun sm-def-menu (name prompt help-header items)
 "define a menu object"
 ;; check for errors on the way in and massage args
 (if (not (symbolp name))
     (error (format "%s, the first arg must be a symbol." name)))
 (cond
   ( (get name 'items) ;it's been created already
     (sm-add-to-menu name items)
     (put name 'prompt-header prompt)
     (put name 'help-header help-header))
   (t  ;; doit
     (put name 'items items)
     (set name (sm-menu-ized-items items))
     (put name 'prompt-header prompt)
     (put name 'help-header help-header)
     t)) )

(fset 'def-menu 'sm-def-menu)

(defun sm-add-to-menu (menu items)
  "Add to NAME the list of ITEMS."
  (mapcar '(lambda (x) (sm-add-to-menu-item menu x))
          items))

(defun sm-add-to-menu-item (menu item)
  (let ( (old-items (get menu 'items)) )
   (cond ( (member item old-items) )
         (t
           (put menu 'items (append old-items items))
           (set menu (sm-menu-ized-items (get menu 'items)))
           (put menu 'full-prompt nil)))
  ))

(fset 'add-to-menu 'sm-add-to-menu)
;;;
;;;        Running functions
;;;

(defun sm-run-menu (amenu)
 "present a menu"
 ;; get & present the prompt
 (if (= (length (eval amenu)) 1)
     (sm-eval-single-menu amenu)
 (let ((prompt (get amenu 'prompt-header))
       (full-prompt (get amenu 'full-prompt))
       (old-window (selected-window))
       (items (eval amenu))    )
  (if (not (string= prompt "")) (setq prompt (concat prompt ": ")))
  (if full-prompt
      (message full-prompt)
      (progn
        ;; this makes a full prompt, & saves it for later use
        (mapcar (function (lambda (x) (setq prompt (concat prompt x " "))))
                (mapcar 'first-word items))
        (setq prompt (concat prompt simple-menu-help-string))
        (put amenu 'full-prompt prompt)
        (message prompt)))
  ;; read it in & process char choice
  (let ( (cursor-in-echo-area t)
         (echo-keystrokes 0) )
  (setq opt (read-char)) )
  (setq opt (downcase opt))
  (if (or (= opt ?\C-h) (= opt ??)  (= opt ? ))
      (setq opt (downcase (pop-up-help amenu))))
  (sm-eval-menu amenu opt)
 )))

(fset 'run-menu 'sm-run-menu)


;;;
;;;     III.     Helper functions
;;;

(defun sm-eval-menu (amenu opt)
 "find in AMENU the command corresponding to OPT."
 (let ( (items (eval amenu))
        (command nil) )
  (while items
     (setq item (pop items))
     (cond ( (= opt (third item))
             (setq items nil)
             (setq command (second item))
             (cond ;; its a command
                   ((and (not (listp command)) (fboundp command))
                    (call-interactively command)
            (sm-note-function-key command))
                   ;; it is something to eval
                   ((listp command)
                    (eval command))
                   ;; it is another menu, you hope...
                   (t (sm-run-menu command))))))
  (if (not command) ; no match
      (progn (message (format "%c did not match a menu name" opt))
             (beep)))      ;note we lost
))

(defun sm-eval-single-menu (amenu)
 "run in AMENU the single only command."
 (let* ( (item (first (eval amenu)))
         (command (second item)) )
   (cond ;; its a command
        ((and (not (listp command)) (fboundp command))
         (call-interactively command)
         (sm-note-function-key command))
        ;; it is something to eval
        ((listp command)
         (eval command))
        ;; it is another menu, you hope...
        (t (sm-run-menu command)))
   (if (not command) ; no match
       (progn (message (format "%c did not match a menu name" opt))
              (beep)))     ;note we lost
))

(defun sm-make-help (help-header name items)
 "make a help string for a simple menu"
 (let ((header nil) (result ""))
  (setq result
        (concat result
               (cond ((string= "" help-header)
                      (format "%s %s:%s" sm-default-help-header name CR CR))
                     (t (concat help-header ":" CR CR)))))
  (mapcar (function
            (lambda (x)
               (let ((bind-thing (sm-find-binding (car (cdr x))))
                     (help-string (car x)) )
               (setq result (format "%s %s " result help-string))
               (if bind-thing
                   (setq result (format "%s (%s)" result bind-thing)))
               (setq result (concat result CR))           )))
          items)
  (setq result (concat result CR " " sm-default-help-for-help ))
  (setq result (concat result CR " " sm-default-help-footer))
  result))

(defun sm-find-binding (function)
 "Finds a keybinding for function if it can."
 (cond
   ((car (where-is-internal function (current-local-map))))
    ;; check escape map too
   ( (let ((esc-key (where-is-internal function
                                       (lookup-key (current-local-map) ""))))
      (if esc-key
         (concat "M-" (car esc-key)))))
   ( (symbolp function)
     ;; this assumes that function in interactive
     (message (format "\"ESC-X %s\""
                  function)))))


(defun sm-menu-ized-items (items)
 "strips the first letter off and makes it the third item for ease and speed"
 (mapcar (function (lambda (x) (append x (list (string-to-char (first-letter x))))))
         items))


(defun pop-up-help (menu)
  "Display the full documentation of MENU."
  ;; changed to work on menu items.
  (let ((opt nil) (opt-key 'beep) (full-prompt (get menu 'full-prompt))
        (help-info
           (cond ((get menu 'help))
                 ((put menu 'help (sm-make-help (get menu 'help-header)
                                                menu
                                                (get menu 'items))))
                 (t "not documented")))  )
    (save-window-excursion
      (switch-to-buffer help-buffer)
      (erase-buffer)
      (insert help-info)
      (goto-char (point-min))
      (while (not (equal opt-key 'self-insert-command))
        (message full-prompt)
        (setq opt (read-key-sequence nil))
        (setq opt-key (lookup-key (current-global-map) opt))
        (if (memq opt-key
                  (append
                   (if (not (pos-visible-in-window-p (point-min)))
                       '(scroll-up))
                   (if (not (pos-visible-in-window-p (point-max)))
                       '(scroll-down))
                   '(next-line previous-line forward-line forward-char
                     backward-char keyboard-quit scroll-right scroll-left)))
            (call-interactively opt-key)
          (bury-buffer help-buffer))))
    (string-to-char opt)))

(defun sm-note-function-key (command)
 "Note to the user any keybindings for Command"
 (let ( (key-binding (sm-find-binding command)) )
   ;(setq aa command)
  (cond
   (key-binding
    (message (format "%s is also bound to \"%s\"."
             command key-binding))) )))


;;;
;;;     IV.    Utilities
;;;

;; (first-word '("asdf" fun1))
;; (first-letter '("Asdf" fun1))

(defun first-word (menu-item)
 "return the first word of the first part (a string) of MENU-ITEM"
 (let ((string  (car menu-item)))
  (substring string 0 (string-match " " string))))

(defun first-letter (menu-item)
 "return the first letter of the first part (a string) of MENU-ITEM"
 (let ((string  (first-word menu-item)))
    (downcase (substring string 0 1))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sample usage:
;
;(defun run-soar-menu ()
;  "provide a menu of commands for Soar and Taql."
;  (interactive)
;  (run-menu 'soar-menu))
;
;(def-menu
;  'soar-menu
;  "" ;main prompt
;  "The menu key allows you to select various command options" ;help prompt
;   ;123456789012345
; '(("Documents       Examine various manuals."   soar-document-menu)
;   ("Emacs           Do plain Emacs commands."   emacs-menu)
;   ("Soar            Do primarily Soar commands." soar-command-menu)
;   ("Lisp            Do primarily Lisp commands." lisp-command-menu)
;))
;
;(def-menu
;  'soar-document-menu
;  "" ;main prompt
;  "The menu key allows you to select various documents to browse:" ;help prompt
;  ;; all manuals should live in the manuals sub-directory
; '(("1-Soar5.2    Main Soar manual."       (goto-manual "Soar5-manual.doc"))
;   ("2-soar-mode  soar-mode manual."       (goto-manual "soar-mode.doc"))
;   ("3-DSI        DSI manual.      "       (goto-manual "dsi-manual.doc"))
;))
;
;(def-menu
;   'emacs-menu
;  "Emacs commands"
;  "Menu of plain Emacs commands"
; '(("Windows      Manipulate multiple window settings."            windows-menu)
;   ("Modify       Change your editing environment."                modify-menu)
;   ("Block menu   Perform operations on blocks (regions) of text." block-menu)
;))
;
;(def-menu  'block-menu
;  "Block Option"
;  "Displays menu of block commands to chose from"
; '(("Align    Adjust all lines in region Left, Right, or Centered." align-menu)
;  ("Eval     Evaluate region as a Lisp expression."                eval-region)
;  ("Fill     Fill each paragraph in the region."                   fill-region)
;  ("Indent   Indent region according to major mode."          indent-region)
;  ("Lower    Convert all characters in region to lowercase."  downcase-region)
;  ("Narrow   Narrow scope of edit to region."                 narrow-to-region)
;  ("Spell    Check spelling of all words in region."          spell-region)
;  ("Upcase   Convert all characters in region to uppercase."  upcase-region)
;  ))
;
;
;(def-menu 'modify-menu
;  "Modify Option"
;  "Modify editing environment options are"
; '(("Keys     Locally rebind a key to a function."      local-set-key)
;  ("Mode     Change current major/minor mode."         mode-menu)
;  ("Options  Change environmental variable values."    (edit-options))
;  ("Save     Save current options settings to a file."
;   (message "Modify Save not implemented yet."))
;  ("Tabs     Modify tab stop locations."               edit-tab-stops))  )
;
;(def-menu 'soar-command-menu
;  "Soar Options"
;  "" ;help prompt
; '(
;   ("Run          Switch to the running Soar buffer." switch-to-lisp)
;   ("Break        Interupt current lisp."
;                 (progn (switch-to-lisp t)
;                        (interrupt-subjob-ilisp)))
;   ("Prod         Do stuff to productions." production-command-menu)
;   ("Load         load TC or production into Soar."
;                  eval-defun-and-go-lisp)
;   ("Commands     Other commands in soar-mode."   other-soar-command-menu)
;   ("Varset       menu to set variables."   soar-variables-menu)))
;
;(def-menu 'other-soar-command-menu
;  "Other Soar commands"
;  "" ;help prompt
; '(
;   ("Header       Make a file header." make-header)
;   ("Rev          Make a revision line in header." make-revision)
;   ("Tag          Make a tags table for a list of files." make-tags-table)
;   ("Rtags        Remake a tags table for a list of files.
;                   (This is faster than Tag.)"           remake-tags-table)
;   ("Count        Count the number of productions in current buffer."
;                  soar-count-productions)
;))
;
;(def-menu 'production-command-menu
;  "Production"
;  "" ;help prompt
;
; '(("Trace        Traces the previous production." soar-ptrace-production)
;   ("Full         Full-matches on production." soar-full-matches-production)
;   ("Xcise        Excise production."     soar-excise-production)
;   ("Smatch       SMatch production."  soar-smatches-production)
;   ("Break        Pbreak production." soar-pbreak-production)
;   ("Prin         SPR production."  soar-spr-production)
;   )
;)
;
;(def-menu 'lisp-command-menu
;  "Lisp"
;  "" ;help prompt
; '(("Arg          Apropos on CL manual." fi:clman-apropos)
;   ("Doc          Check Common Lisp manual." fi:clman)
;   ("UDoc         Get documentation string." documentation-lisp)
;   ("Xpand        macroexpand-lisp."        macroexpand-lisp)
;   ("0Eval        Eval the surrounding defun." eval-defun-lisp)
;   ("1Eval        Eval defun and goto Soar." eval-region-and-go-lisp)
;   ("Rglist       Get the arglist for function." arglist-lisp)
;   (";            Comment the region."   comment-region-lisp)
;   (")            find-unbalanced-lisp parens." find-unbalanced-lisp)
;   ("Prev         Display the previous input." comint-previous-input)
;   ("]            close-all-lisp parens that are open." close-all-lisp)
;   ("Trace        Traces the previous function symol." trace-lisp)
;   )
;)
;
;;; example of leaving old format in
;(defun replace-menu ()
;  "Options for finding & replacing strings in current buffer:
; Interactive  Check each occurance before replace. [default]
; All          Replace all occurances without asking.
; -------
; Regexp   Search & replace using a regular expression.
; String   Search & replace any string of characters.
; Tags     Search & replace through all files listed in tag table.
;"
;  (interactive)
;  (let ((prompt "Replace: All Help Regexp String Tag ")
;        (opt nil)
;        (forward t)
;        (interactive t))
;    (while (not opt)
;      (message prompt)
;      (setq opt (downcase (read-char)))
;      (if (= opt ?h) (setq opt (pop-up-help 'replace-menu "Replace option: ")))
;      (cond ((= opt ?i)                 ; Set for interactive search
;             (setq interactive t)
;             (setq prompt "Replace: All Help Regexp String Tag ")
;             (setq opt nil))
;            ((= opt ?a)                 ; Set for noninteractive search
;             (setq interactive nil)
;             (setq prompt "Replace: Interactive Help Regexp String Tag ")
;             (setq opt nil))
;            ((= opt ?s)                 ; String replace
;             (if interactive (call-interactively 'query-replace)
;               (call-interactively 'replace-string)))
;            ((= opt ?r)                 ; Regexp search
;             (if interactive (call-interactively 'query-replace-regexp)
;               (call-interactively 'replace-regexp)))
;            ((= opt ?t)                 ; Tags search
;             (call-interactively 'tags-query-replace))
;            (t (ding)))))
;  )
;
;
;(def-menu 'windows-menu
;  ""
;  "Displays menu of window commands to chose from"
; '(("Buffers  Change to buffers menu."                             buffer-menu)
;  ("Compare  Compare text in current window with text in next window."
;   (message "Compare not implemented yet."))
;  ("Delete   Remove current window from the display."               delete-window)
;  ("Find     Find another buffer and change current window to it."  select-window)
;  ("Split    Divide current window Vertically or Horizontally."
;   (progn
;    (while (not (or (= opt ?h) (= opt ?v)))
;      (message "Split window: Horizontally Vertically ")
;      (setq opt (downcase (read-char))))
;    (if (= opt ?h)
;        (call-interactively 'split-window-horizontally)
;        (call-interactively 'split-window-vertically))   ))
;  ("Other    Change to next window."                      other-window)
;  ("1        Make current window the only one visible."   (delete-other-windows))
;  ("+        Increase lines in current window."           (do-window-sizing))
;  ("-        Decrease lines in current window."           (do-window-sizing))
;  ("<        Increase columns in current window."         (do-window-sizing))
;  (">        Decrease columns in current window."         (do-window-sizing))))
;
;(defun do-window-sizing ()
; ;; is opt passed down?
; (while (or (= opt ?+) (= opt ?-) (= opt ?>) (= opt ?<))
;   (message "Change window size press '+', '-', '<', '>', or space to quit.")
;   (if (= opt ?+) (enlarge-window 1))
;   (if (= opt ?-) (shrink-window 1))
;   (if (= opt ?>) (enlarge-window-horizontally 1))
;   (if (= opt ?<) (shrink-window-horizontally 1))
;   (setq opt (read-char))))
;
;
;(def-menu 'buffer-menu
;  ""
;  "Displays menu of buffer commands to chose from"
; '(("Delete   Kill current buffer."               kill-buffer)
;  ("Edit     Edit another buffer."               switch-to-buffer)
;  ("File     Change to use File menu."           files-menu)
;  ("List     List current buffers and status."   list-buffers)
;  ("Other    Switch to buffer in other window."  switch-to-buffer-other-window)
;  ("Spell    Check spelling for current buffer." ispell-buffer)
;  ("Toggle   Toggle current buffer read-only status." toggle-read-only)
;  ("Window   Change to Windows menu."                 windows-menu)))
;
;(def-menu 'mode-menu
;  "Mode"
;  "Displays menu of known major and minor modes to chose from"
; '(("1  [pfe-mode] Use PFE emulation and keyboard layout."   (pfe-mode))
;  ("A  [edit-abbrevs-mode] Major mode for editing list of abbrev definitions."
;     (edit-abbrevs-mode))
;  ("C  [c-mode] Major mode for editing C language source files."   (c-mode))
;  ("D  [normal-mode] Default to normal mode for current file."  (normal-mode))
;  ("F  [fortran-mode] Major mode for editing FORTRAN source files."
;    (fortran-mode))
;  ("G  [emacs-lisp-mode] Major mode for editing GNU Emacs lisp source files."
;     (emacs-lisp-mode))
;  ("I  [lisp-interaction-mode] Major mode for typing/evaluating Lisp forms."
;     (lisp-interaction-mode))
;  ("L  [lisp-mode] Major mode for editing LISP code other than Emacs Lisp."
;    (lisp-mode))
;  ("O  [outline-mode] Major mode for editing outlines with selective display."
;     (outline-mode))
;  ("P  [picture-mode] Use quarter-plane screen model to edit."  (picture-mode))
;  ("T  [text-mode] Major mode for editing regular text files." (text-mode))
;  ("X  [tex-mode] Major mode for editing files of input for TeX or LaTeX."
;     (tex-mode))
;  ("Z  [fundamental-mode] Major mode not specialized for anything."
;    (fundamental-mode))))
;
;(def-menu 'align-menu
;  "Align Option"
;  "Displays menu of region alignment commands to chose from:"
; '(("Center   Center all lines in region between left margin and fill column."
;     center-region)
;  ("Justify  Fill each paragraph between left margin and fill column."
;     (fill-region (point) (mark) t))
;  ("Left     Adjust lines to start in a specific column."
;    (progn (setq opt
;                 (read-input "Align left at column: " (int-to-string left-margin)))
;           (setq opt (string-to-int opt))
;           (message (format "Align left at column %d." opt))
;           (indent-rigidly (point) (mark) opt)))
;  ("Right    Ajdust lines to end in a specific column if possible."
;     (progn (setq opt (read-input "Align right at column: "
;                                  (int-to-string left-margin)))
;            (setq opt (string-to-int opt))
;            (message (format "Align right at column %d." opt))
;            (right-flush-region (point) (mark) opt)))
;  ("Tab      Indent each line in region relative to line above it." indent-region)
;  ))
;