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