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