cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hui-mini.el

   1 ;;; hui-mini.el --- One line command menus for Hyperbole
   2
   3 ;; Copyright (C) 1991-1995, 2004, 2006, 2007 Free Software Foundation, Inc.
   4 ;; Developed with support from Motorola Inc.
   5
   6 ;; Author: Bob Weiner, Brown U.
   7 ;; Maintainer: Mats Lidell <matsl@contactor.se>
   8 ;; Keywords: hypermedia, mouse
   9
  10 ;; This file is part of GNU Hyperbole.
  11
  12 ;; GNU Hyperbole is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 3, or (at
  15 ;; your option) any later version.
  16
  17 ;; GNU Hyperbole is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 ;;;
  32 ;;; Other required Elisp libraries
  33 ;;;
  34
  35 (require 'hypb)
  36
  37 ;;;
  38 ;;; Public variables
  39 ;;;
  40
  41 (defvar hui:menu-select "\C-m"
  42   "*Upper case char-string which selects the Hyperbole menu item at point.")
  43 (defvar hui:menu-quit   "Q"
  44   "*Upper case char-string which quits selecting from a Hyperbole menu item.")
  45 (defvar hui:menu-abort  "\C-g"
  46   "*Same function as 'hui:menu-quit'.")
  47 (defvar hui:menu-top    "\C-t"
  48   "*Character which returns to top Hyperbole menu.")
  49
  50 (defvar hui:menu-p nil
  51   "Non-nil iff a current Hyperbole menu activation exists.")
  52
  53 (defvar hui:menus nil
  54   "Command menus for use with the default Hyperbole user interface.")
  55 (setq
  56  hui:menus
  57  (delq nil
  58  (list (cons
  59         'hyperbole
  60         (append
  61          (let ((version (if (= (aref hyperb:version 0) ?0)
  62                             (substring hyperb:version 1)
  63                           hyperb:version)))
  64            (list (list (concat "Hy" version ">"))))
  65          (delq nil
  66                (list
  67                 '("Act"         hui:hbut-act
  68                   "Activates button at point or prompts for explicit button.")
  69                 '("Butfile/"    (menu . butfile)
  70                   "Quick access button files menus.")
  71                 '("Doc/"        (menu . doc)
  72                   "Quick access to Hyperbole documentation.")
  73                 '("Ebut/"       (menu . ebut)
  74                   "Explicit button commands.")
  75                 '("Gbut/"       (menu . gbut)
  76                   "Global button commands.")
  77                 '("Hist"        (hhist:remove current-prefix-arg)
  78                   "Jumps back to location prior to last Hyperbole button follow.")
  79                 '("Ibut/"       (menu . ibut)
  80                   "Implicit button and button type commands.")
  81                 '("Msg/"        (menu . msg)
  82                   "Mail and News messaging facilities.")
  83                 (if hyperb:kotl-p
  84                     '("Otl/"        (menu . otl)
  85                       "Autonumbered outlining and hyper-node facilities."))
  86                 '("Rolo/"       (menu . rolo)
  87                   "Hierarchical, multi-file rolodex lookup and edit commands.")
  88                 '("Win/"       (menu . win)
  89                   "Window configuration management command.")
  90                 ))))
  91        '(butfile .
  92          (("Butfile>")
  93           ("DirFile"      (find-file hbmap:filename)
  94            "Edits directory-specific button file.")
  95           ("Info"
  96            (id-info "(hyperbole.info)Button Files")
  97            "Displays manual section on button files.")
  98           ("PersonalFile" (find-file
  99                             (expand-file-name hbmap:filename hbmap:dir-user))
 100            "Edits user-specific button file.")
 101           ))
 102        '(doc .
 103          (("Doc>")
 104           ("Demo"         (find-file-read-only
 105                             (expand-file-name "DEMO" hyperb:dir))
 106            "Demonstrates Hyperbole features.")
 107           ("Files"        (find-file-read-only
 108                             (expand-file-name "MANIFEST" hyperb:dir))
 109            "Summarizes Hyperbole system files.  Click on an entry to view it.")
 110           ("Glossary"
 111            (id-info "(hyperbole.info)Glossary")
 112            "Glossary of Hyperbole terms.")
 113           ("HypbCopy"  (id-info "(hyperbole.info)Top")
 114            "Displays general Hyperbole copyright and license details.")
 115           ("Info"      (id-info "(hyperbole.info)Top")
 116            "Online Info version of Hyperbole manual.")
 117           ("MailLists" (id-info "(hyperbole.info)Mail Lists")
 118            "Details on Hyperbole mail list subscriptions.")
 119           ("New"          (progn
 120                             (hact 'link-to-regexp-match
 121                                   "\\*[ \t]+What's New" 2
 122                                   (expand-file-name "README" hyperb:dir))
 123                             (setq buffer-read-only nil)
 124                             (toggle-read-only))
 125            "Recent changes to Hyperbole.")
 126           ("SmartKy"      (find-file-read-only (hypb:mouse-help-file))
 127            "Summarizes Smart Key mouse or keyboard handling.")
 128           ("Types/"       (menu . types)
 129            "Provides documentation on Hyperbole types.")
 130          ))
 131        '(ebut .
 132          (("EButton>")
 133           ("Act"    hui:hbut-act
 134             "Activates button at point or prompts for explicit button.")
 135           ("Create" hui:ebut-create)
 136           ("Delete" hui:ebut-delete)
 137           ("Edit"   hui:ebut-modify "Modifies any desired button attributes.")
 138           ("Help/"  (menu . ebut-help) "Summarizes button attributes.")
 139           ("Info"
 140            (id-info "(hyperbole.info)Explicit Buttons")
 141            "Displays manual section on explicit buttons.")
 142           ("Modify" hui:ebut-modify "Modifies any desired button attributes.")
 143           ("Rename" hui:ebut-rename "Relabels an explicit button.")
 144           ("Search" hui:ebut-search
 145            "Locates and displays personally created buttons in context.")
 146           ))
 147        '(ebut-help .
 148          (("Help on>")
 149           ("BufferButs"   (hui:hbut-report -1)
 150            "Summarizes all explicit buttons in buffer.")
 151           ("CurrentBut"   (hui:hbut-report)
 152            "Summarizes only current button in buffer.")
 153           ("OrderedButs"  (hui:hbut-report 1)
 154            "Summarizes explicit buttons in lexicographically order.")
 155           ))
 156        '(gbut .
 157          (("GButton>")
 158           ("Act"    gbut:act        "Activates global button by name.")
 159           ("Create" hui:gbut-create "Adds a global button to gbut:file.")
 160           ("Edit"   hui:gbut-modify "Modifies global button attributes.")
 161           ("Help"   gbut:help       "Reports on a global button by name.")
 162           ("Info"   (id-info "(hyperbole.info)Global Buttons")
 163            "Displays manual section on global buttons.")
 164           ("Modify" hui:gbut-modify "Modifies global button attributes.")
 165           ))
 166        '(ibut .
 167          (("IButton>")
 168           ("Act"    hui:hbut-act    "Activates implicit button at point.")
 169           ("DeleteIButType"   (hui:htype-delete 'ibtypes)
 170            "Deletes specified button type.")
 171           ("Help"   hui:hbut-help   "Reports on button's attributes.")
 172           ("Info"   (id-info "(hyperbole.info)Implicit Buttons")
 173            "Displays manual section on implicit buttons.")
 174           ("Types"  (hui:htype-help 'ibtypes 'no-sort)
 175            "Displays documentation for one or all implicit button types.")
 176           ))
 177        '(msg .
 178          (("Msg>")
 179           ("Compose-Hypb-Mail"
 180            (hmail:compose "hyperbole-users@gnu.org" '(hact 'hyp-config))
 181            "Send a message to the Hyperbole discussion list.")
 182           ("Bug-Report"
 183            (hmail:compose "bug-hyperbole@gnu.org" '(hact 'hyp-config))
 184            "Send a bug report")
 185           ("List-Admin" (menu . mailadm)
 186            "Administer subscription to the mail lists.")
 187           ))
 188        (if hyperb:kotl-p
 189            '(otl
 190              . (("Otl>")
 191                 ("All"       kotl-mode:show-all "Expand all collapsed cells.")
 192                 ("Blanks"    kvspec:toggle-blank-lines
 193                  "Toggle blank lines between cells on or off.")
 194                 ("Create"    kfile:find   "Create or edit an outline file.")
 195                 ("Downto"    kotl-mode:hide-sublevels
 196                  "Hide all cells in outline deeper than a particular level.")
 197                 ("Examp"   (find-file-read-only
 198                               (expand-file-name
 199                                "EXAMPLE.kotl" (concat hyperb:dir "kotl/")))
 200                  "Display a self-descriptive example outline file.")
 201                 ("Hide"      (progn (kotl-mode:is-p)
 202                                     (kotl-mode:hide-tree (kcell-view:label)))
 203                  "Collapse tree rooted at point.")
 204                 ("Info"
 205                  (id-info "(hyperbole.info)Outliner")
 206                  "Display manual section on Hyperbole outliner.")
 207                 ("Kill"      kotl-mode:kill-tree
 208                  "Kill ARG following trees starting from point.")
 209                 ("Link"      klink:create
 210                  "Create and insert an implicit link at point.")
 211                 ("Overvw"  kotl-mode:overview
 212                  "Show first line of each cell.")
 213                 ("Show"      (progn (kotl-mode:is-p)
 214                                     (kotl-mode:show-tree (kcell-view:label)))
 215                  "Expand tree rooted at point.")
 216                 ("Top"       kotl-mode:top-cells
 217                  "Hide all but top-level cells.")
 218                 ("Vspec"     kvspec:activate
 219                  "Prompt for and activate a view specifiction.")
 220                 )))
 221        '(rolo .
 222          (("Rolo>")
 223           ("Add"              rolo-add    "Add a new rolo entry.")
 224           ("Display"          rolo-display-matches
 225            "Display last found rolodex matches again.")
 226           ("Edit"             rolo-edit   "Edit an existing rolo entry.")
 227           ("Info"             (id-info "(hyperbole.info)Rolodex")
 228            "Displays manual section on Hyperbole rolodex.")
 229           ("Kill"             rolo-kill   "Kill an existing rolo entry.")
 230           ("Mail"             rolo-mail-to "Mail to address following point.")
 231           ("Order"            rolo-sort   "Order rolo entries in a file.")
 232           ("RegexFind"        rolo-grep   "Find entries containing a regexp.")
 233           ("StringFind"       rolo-fgrep  "Find entries containing a string.")
 234           ("WordFind"         rolo-word   "Find entries containing words.")
 235           ("Yank"             rolo-yank
 236            "Find an entry containing a string and insert it at point.")
 237           ))
 238        '(types .
 239          (("Types>")
 240           ("ActionTypes"      (hui:htype-help   'actypes)
 241            "Displays documentation for one or all action types.")
 242           ("IButTypes"        (hui:htype-help   'ibtypes 'no-sort)
 243            "Displays documentation for one or all implicit button types.")
 244           ))
 245        '(win .
 246          (("WinConfig>")
 247           ("AddName"        wconfig-add-by-name
 248            "Name current window configuration.")
 249           ("DeleteName"     wconfig-delete-by-name
 250            "Delete named window configuration.")
 251           ("RestoreName"    wconfig-restore-by-name
 252            "Restore frame to window configuration given by name.")
 253           ("PopRing"        (progn (wconfig-delete-pop)
 254                                    (hyperbole 'win))
 255            "Restores window configuration from ring and removes it from ring.")
 256           ("SaveRing"       (wconfig-ring-save)
 257            "Saves current window configuration to ring.")
 258           ("YankRing"       (progn (call-interactively 'wconfig-yank-pop)
 259                                    (hyperbole 'win))
 260            "Restores next window configuration from ring.")
 261           ))
 262        '(mailadm .
 263          (("MailAdmin>")
 264           ("Hyperbole-Users-Adm"
 265            (browse-url "http://lists.gnu.org/mailman/listinfo/hyperbole-users")
 266            "Point web browser to administrative interface")
 267           ("Bug-Hypberbole-Adm"
 268            (browse-url "http://lists.gnu.org/mailman/listinfo/bug-hyperbole")
 269            "Point web browser to administrative interface")
 270           ))
 271        )))
 272
 273 ;;;
 274 ;;; Public functions
 275 ;;;
 276
 277 ;;; Old name
 278 (fset 'hui:menu 'hyperbole)
 279
 280 ;;; Used as autoloaded main entry point to Hyperbole (but hsite.el) is the
 281 ;;; file that is autoloaded when this is invoked.
 282 ;;; It brings up a menu of commands.
 283 (defun hyperbole (&optional menu menu-list)
 284   "Invokes default Hyperbole menu user interface when not already active.
 285 Suitable for binding to a key, e.g. {C-h h}.
 286 Non-interactively, returns t if menu is actually invoked by call, else nil.
 287
 288 Two optional arguments may be given to invoke alternative menus.
 289 MENU (a symbol) specifies the menu to invoke from MENU-LIST, (a
 290 Hyperbole menu list structure).  MENU defaults to 'hyperbole and MENU-LIST
 291 to `hui:menus'.  See `hui:menus' definition for the format of the menu list
 292 structure."
 293
 294   (interactive)
 295   (if (and hui:menu-p (> (minibuffer-depth) 0))
 296       (progn (beep) nil)
 297     (unwind-protect
 298         (progn
 299           (require 'hsite) ;; Since "hui-mini" may be loaded without loading
 300                            ;; all of Hyperbole.
 301           (if hyperbole-on-menubar (hyperb:init-menubar))
 302           (setq hui:menu-p t)
 303           (hui:menu-act (or menu 'hyperbole) menu-list)
 304           t)
 305       (setq hui:menu-p nil))))
 306
 307 (defun hui:menu-act (menu &optional menu-list)
 308   "Prompts user with Hyperbole MENU (a symbol) and performs selected item.
 309 Optional second argument MENU-LIST is a Hyperbole menu list structure from
 310 which to extract MENU.  It defaults to `hui:menus'.  See its definition for
 311 the menu list structure."
 312   (let ((set-menu '(or (and menu (symbolp menu)
 313                             (setq menu-alist
 314                                   (cdr (assq menu (or menu-list hui:menus)))))
 315                        (hypb:error "(menu-act): Invalid menu symbol arg: %s"
 316                               menu)))
 317         (show-menu t)
 318         (rtn)
 319         menu-alist act-form)
 320     (while (and show-menu (eval set-menu))
 321       (cond ((and (consp (setq act-form (hui:menu-select menu-alist)))
 322                   (cdr act-form)
 323                   (symbolp (cdr act-form)))
 324              ;; Display another menu
 325              (setq menu (cdr act-form)))
 326             (act-form
 327              (let ((prefix-arg current-prefix-arg))
 328                (cond ((symbolp act-form)
 329                       (if (eq act-form t)
 330                           nil
 331                         (setq show-menu nil
 332                               rtn (call-interactively act-form))))
 333                      ((stringp act-form)
 334                       (hui:menu-help act-form)
 335                       ;; Loop and show menu again.
 336                       )
 337                      (t (setq show-menu nil
 338                               rtn (eval act-form))))))
 339             (t (setq show-menu nil))))
 340     rtn))
 341
 342 (defun hui:menu-enter (&optional char-str)
 343   "Uses CHAR-STR or last input character as minibuffer argument."
 344   (interactive)
 345   (let ((input (or char-str (aref (recent-keys) (1- (length (recent-keys)))))))
 346     (cond (hyperb:emacs19-p
 347            (and (not (integerp input))
 348                 (eventp input)
 349                 (setq input (event-basic-type input))))
 350           (hyperb:xemacs-p
 351            (if (eventp input)
 352                (setq input (event-to-character input)))))
 353     (if (or (symbolp input)
 354             (and (integerp input)
 355                  (= input ?\r)))
 356         (setq input (hargs:at-p)))
 357     (erase-buffer)
 358     (or (symbolp input) (insert input)))
 359   (exit-minibuffer))
 360
 361 (defun hui:menu-help (help-str)
 362   "Displays HELP-STR in a small window.  HELP-STR must be a string."
 363   (let* ((window-min-height 2)
 364          (owind (selected-window))
 365          (buf-name (hypb:help-buf-name "Menu")))
 366     (unwind-protect
 367         (progn
 368           (save-window-excursion
 369             (hkey-help-show buf-name)) ;; Needed to save wconfig.
 370           (if (eq (selected-window) (minibuffer-window))
 371               (other-window 1))
 372           (if (= (length (hypb:window-list 'no-mini)) 1)
 373               (split-window-vertically nil))
 374           (select-window (hui:bottom-window))
 375           (switch-to-buffer (get-buffer-create buf-name))
 376           (setq buffer-read-only nil)
 377           (erase-buffer)
 378           (insert "\n" help-str)
 379           (set-buffer-modified-p nil)
 380           (shrink-window
 381            (- (window-height)
 382               (+ 3 (length
 383                     (delq nil
 384                           (mapcar (function
 385                                    (lambda (chr) (= chr ?\n)))
 386                                   help-str)))))))
 387       (select-window owind))))
 388
 389 (defun hui:menu-xemacs (&optional menu menu-list)
 390   "Returns an XEmacs menu built from Hyperbole type menus.
 391 Optional MENU (a symbol) specifies a specific submenu of optional MENU-LIST.
 392 a Hyperbole menu list structure.  Otherwise, all menus are used.
 393 MENU defaults to 'hyperbole and MENU-LIST to `hui:menus'.  See `hui:menus'
 394 definition for the format of the menu list structure."
 395   (mapcar
 396    (function
 397     (lambda (entry)
 398       (or (consp entry)
 399           (error "(hui:menu-xemacs): Invalid menu entry: %s" entry))
 400       (let ((label (car entry))
 401             (content (car (cdr entry))))
 402         (cond ((null content) (hypb:replace-match-string ">$" label "" t))
 403               ((and (consp content) (eq (car content) 'menu))
 404                (hui:menu-xemacs (cdr content)))
 405               (t (vector label content 't))))))
 406    (cdr (assq (or menu 'hyperbole) (or menu-list hui:menus)))))
 407
 408 (defun hui:menu-select (menu-alist)
 409   "Prompts user to choose the first character of any item from MENU-ALIST.
 410 Case is not significant.  If chosen by direct selection with the Assist Key,
 411 returns any help string for item, else returns the action form for the item."
 412   (let* ((menu-line (hui:menu-line menu-alist))
 413          (set:equal-op 'eq)
 414          (select-char (string-to-char hui:menu-select))
 415          (quit-char (string-to-char hui:menu-quit))
 416          (abort-char (string-to-char hui:menu-abort))
 417          (top-char  (string-to-char hui:menu-top))
 418          (item-keys (mapcar (function
 419                              (lambda (item) (aref item 0)))
 420                             (mapcar 'car (cdr menu-alist))))
 421          (keys (apply 'list select-char quit-char abort-char
 422                       top-char item-keys))
 423          (key 0)
 424          (hargs:reading-p 'hmenu)
 425          sublist)
 426     (while (not (memq (setq key (upcase
 427                                  (string-to-char
 428                                   (read-from-minibuffer
 429                                    "" menu-line hui:menu-mode-map))))
 430                       keys))
 431       (beep)
 432       (setq hargs:reading-p 'hmenu)
 433       (discard-input))
 434     (cond ((eq key quit-char) nil)
 435           ((eq key abort-char) (beep) nil)
 436           ((eq key top-char) '(menu . hyperbole))
 437           ((and (eq key select-char)
 438                 (save-excursion
 439                   (if (search-backward " " nil t)
 440                       (progn (skip-chars-forward " ")
 441                              (setq key (following-char))
 442                              nil)  ;; Drop through.
 443                     t))))
 444           (t (if (setq sublist (memq key item-keys))
 445                  (let* ((label-act-help-list
 446                          (nth (- (1+ (length item-keys)) (length sublist))
 447                               menu-alist))
 448                         (act-form (car (cdr label-act-help-list))))
 449                    (if (eq hargs:reading-p 'hmenu-help)
 450                        (let ((help-str
 451                               (or (car (cdr (cdr label-act-help-list)))
 452                                   "No help documentation for this item.")))
 453                          (concat (car label-act-help-list) "\n  "
 454                                  help-str "\n    Action: "
 455                                  (prin1-to-string act-form)))
 456                      act-form)))))))
 457
 458 ;;;
 459 ;;; Private functions
 460 ;;;
 461
 462 (if (fboundp 'window-lowest-p)
 463     (defun hui:bottom-window ()
 464       "Return a window that is at the bottom of the selected frame."
 465       (let ((winds (hypb:window-list 'no-mini))
 466             (window))
 467         (while (and (not window) winds)
 468           (if (window-lowest-p (car winds))
 469               (setq window (car winds))
 470             (setq winds (cdr winds))))
 471         window))
 472   (defun hui:bottom-window ()
 473     "Return a window that is at the bottom of the selected frame."
 474     (let* ((winds (hypb:window-list 'no-mini))
 475            (bot-list (mapcar
 476                       (function
 477                        (lambda (wind)
 478                          (nth 3 (window-edges wind))))
 479                       winds))
 480            (bot (apply 'max bot-list)))
 481       (nth (- (length winds) (length (memq bot bot-list))) winds))))
 482
 483 (defun hui:menu-line (menu-alist)
 484   "Returns a menu line string built from MENU-ALIST."
 485   (let ((menu-prompt (concat (car (car menu-alist)) "  "))
 486         (menu-items (mapconcat 'car (cdr menu-alist) "  "))
 487         menu-line)
 488     (setq menu-line (concat menu-prompt menu-items))
 489     ;; Narrow menu by changing 2 spaces to 1 if too wide for current frame.
 490     (if (>= (length menu-line) (1- (frame-width)))
 491         (concat menu-prompt (mapconcat 'car (cdr menu-alist) " "))
 492       menu-line)))
 493
 494 ;;;
 495 ;;; Private variables
 496 ;;;
 497
 498 ;; Hyperbole menu mode is suitable only for specially formatted data.
 499 (put 'hui:menu-mode 'mode-class 'special)
 500
 501 (defvar hui:menu-mode-map nil
 502   "Keymap containing hui:menu commands.")
 503 (if hui:menu-mode-map
 504     nil
 505   (setq hui:menu-mode-map (make-keymap))
 506   (suppress-keymap hui:menu-mode-map)
 507   (define-key hui:menu-mode-map hui:menu-quit   'hui:menu-enter)
 508   (define-key hui:menu-mode-map hui:menu-abort  'hui:menu-enter)
 509   (define-key hui:menu-mode-map hui:menu-top    'hui:menu-enter)
 510   (define-key hui:menu-mode-map hui:menu-select 'hui:menu-enter)
 511   ;;
 512   ;; This next binding is necessary since the default button1 binding under
 513   ;; XEmacs, mouse-track, is broken under XEmacs V19.8.
 514   (and hyperb:xemacs-p window-system
 515        (define-key hui:menu-mode-map 'button1 'mouse-set-point))
 516   (let ((i 32))
 517     (while (<= i 126)
 518       (define-key hui:menu-mode-map (char-to-string i) 'hui:menu-enter)
 519       (setq i (1+ i)))))
 520
 521 (provide 'hui-mini)
 522
 523 ;;; hui-mini.el ends here