lisp/tmm.el

   1 ;;; tmm.el --- text mode access to menu-bar
   2
   3 ;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.
   4
   5 ;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu>
   6 ;; Maintainer: FSF
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary ============================================================
  25
  26 ;;; To use this package add
  27
  28 ;;; (autoload 'tmm-menubar 'tmm "Text mode substitute for menubar" t)
  29 ;;; (global-set-key [f10] 'tmm-menubar)
  30
  31 ;;; to your .emacs file. You can also add your own access to different
  32 ;;; menus available in Window System Emacs modelling definition after
  33 ;;; tmm-menubar.
  34
  35 (require 'electric)
  36
  37 ;;; The following will be localized, added only to pacify the compiler.
  38 (defvar tmm-short-cuts)
  39 (defvar tmm-old-mb-map nil)
  40 (defvar tmm-old-comp-map)
  41 (defvar tmm-c-prompt)
  42 (defvar tmm-km-list)
  43 (defvar tmm-table-undef)
  44
  45 ;;;###autoload (define-key global-map "\M-`" 'tmm-menubar)
  46 ;;;###autoload (define-key global-map [f10] 'tmm-menubar)
  47 ;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar)
  48
  49 ;;;###autoload
  50 (defun tmm-menubar ()
  51   "Text-mode emulation of looking and choosing from a menubar.
  52 See the documentation for `tmm-prompt'."
  53   (interactive)
  54   (run-hooks 'menu-bar-update-hook)
  55   ;; Obey menu-bar-final-items; put those items last.
  56   (let ((menu-bar (tmm-get-keybind [menu-bar])))
  57     (let ((list menu-bar-final-items))
  58       (while list
  59         (let ((item (car list)))
  60           ;; ITEM is the name of an item that we want to put last.
  61           ;; Find it in MENU-BAR and move it to the end.
  62           (let ((this-one (assq item menu-bar)))
  63             (setq menu-bar (append (delq this-one menu-bar)
  64                                    (list this-one)))))
  65         (setq list (cdr list))))
  66     (tmm-prompt menu-bar)))
  67
  68 (defvar tmm-mid-prompt "==>"
  69   "String to insert between shortcut and menu item or nil.")
  70
  71 (defvar tmm-mb-map nil
  72   "A place to store minibuffer map.")
  73
  74 (defvar tmm-completion-prompt
  75   "Press PageUp Key to reach this buffer from the minibuffer.
  76 Alternatively, you can use Up/Down keys (or your History keys) to change
  77 the item in the minibuffer, and press RET when you are done, or press the
  78 marked letters to pick up your choice.  Type C-g or ESC ESC ESC to cancel.
  79 "
  80   "What insert on top of completion buffer.")
  81
  82 ;;;###autoload
  83 (defun tmm-prompt (bind &optional in-popup)
  84   "Text-mode emulation of calling the bindings in keymap.
  85 Creates a text-mode menu of possible choices. You can access the elements
  86 in the menu:
  87    *)  Either via history mechanism from minibuffer;
  88    *)  Or via completion-buffer that is automatically shown.
  89 The last alternative is currently a hack, you cannot use mouse reliably.
  90 If the optional argument IN-POPUP is set, is argument-compatible with
  91 `x-popup-menu', otherwise the argument BIND should be a cdr of sparse keymap."
  92   (if in-popup (if bind (setq bind in-popup) (x-popup-menu nil in-popup)))
  93   (let (gl-str tmm-km-list out history history-len tmm-table-undef tmm-c-prompt
  94                tmm-old-mb-map tmm-old-comp-map tmm-short-cuts)
  95     (run-hooks 'activate-menubar-hook)
  96     (mapcar (function (lambda (elt)
  97                         (if (stringp elt)
  98                             (setq gl-str elt)
  99                           (and (listp elt) (tmm-get-keymap elt in-popup)))))
 100             bind)
 101     (and tmm-km-list
 102          (progn
 103            (if tmm-mid-prompt
 104                (setq tmm-km-list (tmm-add-shortcuts tmm-km-list))
 105              t)
 106            (setq history (reverse (mapcar 'car tmm-km-list)))
 107            (setq history-len (length history))
 108            (setq history (append history history history history))
 109            (setq tmm-c-prompt (nth (1- history-len) history))
 110            (add-hook 'minibuffer-setup-hook 'tmm-add-prompt)
 111            (unwind-protect
 112                (setq out
 113                      (completing-read
 114                       (concat gl-str " (up/down to change, PgUp to menu): ")
 115                       tmm-km-list nil t nil
 116                       (cons 'history (* 2 history-len))))
 117              (save-excursion
 118                (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt)
 119                (if (get-buffer "*Completions*")
 120                    (progn
 121                      (set-buffer "*Completions*")
 122                      (use-local-map tmm-old-comp-map)
 123                      (bury-buffer (current-buffer)))))
 124              )))
 125     (setq bind (cdr (assoc out tmm-km-list)))
 126     (and (null bind)
 127          (> (length out) (length tmm-c-prompt))
 128          (string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt)
 129          (setq out (substring out (length tmm-c-prompt))
 130                bind (cdr (assoc out tmm-km-list))))
 131     (and (null bind)
 132          (setq out (try-completion out tmm-km-list)
 133                bind (cdr (assoc  out tmm-km-list))))
 134     (setq last-command-event (car bind))
 135     (setq bind (cdr bind))
 136     (if bind
 137          (if in-popup (tmm-prompt t bind)
 138            (if (keymapp bind)
 139                (if (listp bind)
 140                    (progn
 141                      (condition-case nil
 142                          (require 'mouse)
 143                        (error nil))
 144                      (condition-case nil
 145                          (x-popup-menu nil bind) ; Get the shortcuts
 146                        (error nil))
 147                      (tmm-prompt bind))
 148                  (tmm-prompt (symbol-value bind))
 149                  )
 150              (if last-command-event
 151                  (call-interactively bind)
 152                bind)))
 153       gl-str)))
 154
 155
 156 (defun tmm-add-shortcuts (list)
 157   "Adds shortcuts to cars of elements of the list.
 158 Takes a list of lists with a string as car, returns list with
 159 shortcuts added to these cars.
 160 Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
 161   (let ((next-shortcut-number 0))
 162     (mapcar (lambda (elt)
 163               (let ((str (car elt)) f b)
 164                 (setq f (upcase (substring str 0 1)))
 165                 ;; If does not work, try beginning of the other word
 166                 (if (and (member f tmm-short-cuts)
 167                          (string-match " \\([^ ]\\)" str))
 168                     (setq f (upcase (substring
 169                                      str
 170                                      (setq b (match-beginning 1)) (1+ b)))))
 171                 ;; If we don't have an unique letter shortcut,
 172                 ;; pick a digit as a shortcut instead.
 173                 (if (member f tmm-short-cuts)
 174                     (if (< next-shortcut-number 10)
 175                         (setq f (format "%d" next-shortcut-number)
 176                               next-shortcut-number (1+ next-shortcut-number))
 177                       (setq f nil)))
 178                 (if (null f)
 179                     elt
 180                   (setq tmm-short-cuts (cons f tmm-short-cuts))
 181                   (cons (concat f tmm-mid-prompt str) (cdr elt)))))
 182             (reverse list))))
 183
 184 (defun tmm-define-keys ()
 185   (mapcar (lambda (str)
 186             (define-key (current-local-map) str 'tmm-shortcut)
 187             (define-key (current-local-map) (downcase str) 'tmm-shortcut))
 188           tmm-short-cuts)
 189   (define-key (current-local-map) [pageup] 'tmm-goto-completions)
 190   (define-key (current-local-map) [prior] 'tmm-goto-completions)
 191   (define-key (current-local-map) "\ev" 'tmm-goto-completions)
 192   (define-key (current-local-map) "\C-n" 'next-history-element)
 193   (define-key (current-local-map) "\C-p" 'previous-history-element))
 194
 195 (defun tmm-add-prompt ()
 196   (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt)
 197   (make-local-hook 'minibuffer-exit-hook)
 198   (add-hook 'minibuffer-exit-hook 'tmm-delete-map nil t)
 199   (let ((win (selected-window)))
 200     (setq tmm-old-mb-map (current-local-map))
 201     (use-local-map (append (make-sparse-keymap) tmm-old-mb-map))
 202     (tmm-define-keys)
 203     ;; Get window and hide it for electric mode to get correct size
 204     (save-window-excursion
 205       (let ((completions
 206              (mapcar 'car minibuffer-completion-table)))
 207         (with-output-to-temp-buffer "*Completions*"
 208           (display-completion-list completions)))
 209       (set-buffer "*Completions*")
 210       (goto-char 1)
 211       (insert tmm-completion-prompt)
 212       )
 213     (save-excursion
 214       (other-window 1)                  ; Electric-pop-up-window does
 215                                         ; not work in minibuffer
 216       (set-buffer (window-buffer (Electric-pop-up-window "*Completions*")))
 217       (setq tmm-old-comp-map (current-local-map))
 218       (use-local-map (append (make-sparse-keymap) tmm-old-comp-map))
 219       (tmm-define-keys)
 220       (select-window win)               ; Cannot use
 221                                         ; save-window-excursion, since
 222                                         ; it restores the size
 223       )
 224     (insert tmm-c-prompt)))
 225
 226 (defun tmm-delete-map ()
 227   (remove-hook 'minibuffer-exit-hook 'tmm-delete-map t)
 228   (if tmm-old-mb-map
 229       (use-local-map tmm-old-mb-map)))
 230
 231 (defun tmm-shortcut ()
 232   "Choose the shortcut that the user typed."
 233   (interactive)
 234   (let ((c (upcase (char-to-string last-command-char))) s)
 235     (if (member c tmm-short-cuts)
 236         (if (equal (buffer-name) "*Completions*")
 237             (progn
 238               (beginning-of-buffer)
 239               (re-search-forward
 240                (concat "\\(^\\|[ \t]\\)" c tmm-mid-prompt))
 241               (choose-completion))
 242           (erase-buffer)                ; In minibuffer
 243           (mapcar (lambda (elt)
 244                     (if (string=
 245                          (substring (car elt) 0
 246                                     (min (1+ (length tmm-mid-prompt))
 247                                          (length (car elt))))
 248                          (concat c tmm-mid-prompt))
 249                         (setq s (car elt))))
 250                   tmm-km-list)
 251           (insert s)
 252           (exit-minibuffer)))))
 253
 254 (defun tmm-goto-completions ()
 255   (interactive)
 256   (setq tmm-c-prompt (buffer-string))
 257   (erase-buffer)
 258   (switch-to-buffer-other-window "*Completions*")
 259   (search-forward tmm-c-prompt)
 260   (search-backward tmm-c-prompt))
 261
 262
 263 (defun tmm-get-keymap (elt &optional in-x-menu)
 264   "Prepends (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'.
 265 The values are deduced from the argument ELT, that should be an
 266 element of keymap, an `x-popup-menu' argument, or an element of
 267 `x-popup-menu' argument (when IN-X-MENU is not-nil).
 268 Does it only if it is not already there. Uses free variable
 269 `tmm-table-undef' to keep undefined keys."
 270   (let (km str cache (event (car elt)))
 271     (setq elt (cdr elt))
 272     (if (eq elt 'undefined)
 273         (setq tmm-table-undef (cons (cons event nil) tmm-table-undef))
 274       (or
 275        (assoc event tmm-table-undef)
 276        (and (if (listp elt)
 277                 (keymapp elt)
 278               (fboundp elt))
 279             (setq km elt))
 280        (and (if (listp (cdr-safe elt))
 281                 (keymapp (cdr-safe elt))
 282               (fboundp (cdr-safe elt)))
 283             (setq km (cdr elt))
 284             (and (stringp (car elt)) (setq str (car elt))))
 285        (and (if (listp (cdr-safe (cdr-safe elt)))
 286                 (keymapp (cdr-safe (cdr-safe elt)))
 287               (fboundp (cdr-safe (cdr-safe elt))))
 288             (setq km (cdr (cdr elt)))
 289             (and (stringp (car elt)) (setq str (car elt)))
 290             (or (and str
 291                      (stringp (cdr (car (cdr elt)))) ; keyseq cache
 292                      (setq cache (cdr (car (cdr elt))))
 293                      cache (setq str (concat str cache))) str))
 294        (and (if (listp (cdr-safe (cdr-safe (cdr-safe elt))))
 295                 (keymapp (cdr-safe (cdr-safe (cdr-safe elt))))
 296               (fboundp (cdr-safe (cdr-safe (cdr-safe elt)))))
 297                                         ; New style of easy-menu
 298             (setq km (cdr (cdr (cdr elt))))
 299             (and (stringp (car elt)) (setq str (car elt)))
 300             (or (and str
 301                      (stringp (cdr (car (cdr (cdr elt))))) ; keyseq cache
 302                      (setq cache (cdr (car (cdr (cdr elt)))))
 303                      cache (setq str (concat str cache)))
 304                 str))
 305             (and (stringp event)        ; x-popup or x-popup element
 306                  (if (or in-x-menu (stringp (car-safe elt)))
 307                      (setq str event event nil km elt)
 308                    (setq str event event nil km (cons 'keymap elt))
 309                    )))
 310       (and km (stringp km) (setq str km))
 311       (and km str
 312            (or (assoc str tmm-km-list)
 313                (setq tmm-km-list
 314                      (cons (cons str (cons event km)) tmm-km-list)))
 315            ))))
 316
 317
 318 (defun tmm-get-keybind (keyseq)
 319   "Return the current binding of KEYSEQ, merging prefix definitions.
 320 If KEYSEQ is a prefix key that has local and gloibal bindings,
 321 we merge them into a single keymap which shows the proper order of the menu.
 322 However, for the menu bar itself, the value does not take account
 323 of `menu-bar-final-items'."
 324   (let (allbind bind)
 325     (setq bind (key-binding keyseq))
 326     ;; If KEYSEQ is a prefix key, then BIND is either nil
 327     ;; or a symbol defined as a keymap (which satisfies keymapp).
 328     (if (keymapp bind)
 329         (setq bind nil))
 330     ;; If we have a non-keymap definition, return that.
 331     (or bind
 332         (progn
 333           ;; Otherwise, it is a prefix, so make a list of the subcommands.
 334           ;; Make a list of all the bindings in all the keymaps.
 335           (setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq)))
 336           (setq allbind (cons (local-key-binding keyseq) allbind))
 337           (setq allbind (cons (global-key-binding keyseq) allbind))
 338           ;; Merge all the elements of ALLBIND into one keymap.
 339           (mapcar (lambda (in)
 340                     (if (and (symbolp in) (keymapp in))
 341                         (setq in (symbol-function in)))
 342                     (and in (keymapp in)
 343                          (if (keymapp bind)
 344                              (setq bind (nconc bind (copy-sequence (cdr in))))
 345                            (setq bind (copy-sequence in)))))
 346                   allbind)
 347           ;; Return that keymap.
 348           bind))))
 349
 350 (add-hook 'calendar-load-hook (lambda () (require 'cal-menu)))
 351
 352
 353 (provide 'tmm)
 354
 355
 356 ;;; tmm.el ends here