Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hui-mini.el @ 0:376386a54a3c r19-14

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