Source

hyperbole / hui-mini.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
;;; hui-mini.el --- One line command menus for Hyperbole

;; Copyright (C) 1991-1995, 2004, 2006, 2007 Free Software Foundation, Inc.
;; Developed with support from Motorola Inc.

;; Author: Bob Weiner, Brown U.
;; Maintainer: Mats Lidell <matsl@contactor.se>
;; Keywords: hypermedia, mouse

;; This file is part of GNU Hyperbole.

;; GNU Hyperbole is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.

;; GNU Hyperbole is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;;;
;;; Other required Elisp libraries
;;;

(require 'hypb)

;;;
;;; Public variables
;;;

(defvar hui:menu-select "\C-m"
  "*Upper case char-string which selects the Hyperbole menu item at point.")
(defvar hui:menu-quit   "Q"
  "*Upper case char-string which quits selecting from a Hyperbole menu item.")
(defvar hui:menu-abort  "\C-g"
  "*Same function as 'hui:menu-quit'.")
(defvar hui:menu-top    "\C-t"
  "*Character which returns to top Hyperbole menu.")

(defvar hui:menu-p nil
  "Non-nil iff a current Hyperbole menu activation exists.")

(defvar hui:menus nil
  "Command menus for use with the default Hyperbole user interface.")
(setq
 hui:menus
 (delq nil
 (list (cons
	'hyperbole
	(append
	 (let ((version (if (= (aref hyperb:version 0) ?0)
			    (substring hyperb:version 1)
			  hyperb:version)))
	   (list (list (concat "Hy" version ">"))))
	 (delq nil
	       (list
		'("Act"         hui:hbut-act
		  "Activates button at point or prompts for explicit button.")
		'("Butfile/"    (menu . butfile)
		  "Quick access button files menus.")
		'("Doc/"        (menu . doc)
		  "Quick access to Hyperbole documentation.")
		'("Ebut/"       (menu . ebut)
		  "Explicit button commands.")
		'("Gbut/"       (menu . gbut)
		  "Global button commands.")
		'("Hist"        (hhist:remove current-prefix-arg)
		  "Jumps back to location prior to last Hyperbole button follow.")
		'("Ibut/"       (menu . ibut)
		  "Implicit button and button type commands.")
		'("Msg/"        (menu . msg)
		  "Mail and News messaging facilities.")
		(if hyperb:kotl-p
		    '("Otl/"        (menu . otl)
		      "Autonumbered outlining and hyper-node facilities."))
		'("Rolo/"       (menu . rolo)
		  "Hierarchical, multi-file rolodex lookup and edit commands.")
		'("Win/"       (menu . win)
		  "Window configuration management command.")
		))))
       '(butfile .
	 (("Butfile>")
	  ("DirFile"      (find-file hbmap:filename)
	   "Edits directory-specific button file.")
	  ("Info"
	   (id-info "(hyperbole.info)Button Files")
	   "Displays manual section on button files.") 
	  ("PersonalFile" (find-file
			    (expand-file-name hbmap:filename hbmap:dir-user))
	   "Edits user-specific button file.")
	  ))
       '(doc .
	 (("Doc>")
	  ("Demo"         (find-file-read-only
			    (expand-file-name "DEMO" hyperb:dir))
	   "Demonstrates Hyperbole features.")
	  ("Files"        (find-file-read-only
			    (expand-file-name "MANIFEST" hyperb:dir))
	   "Summarizes Hyperbole system files.  Click on an entry to view it.")
	  ("Glossary"
	   (id-info "(hyperbole.info)Glossary")
	   "Glossary of Hyperbole terms.")
	  ("HypbCopy"  (id-info "(hyperbole.info)Top")
	   "Displays general Hyperbole copyright and license details.")
	  ("Info"      (id-info "(hyperbole.info)Top")
	   "Online Info version of Hyperbole manual.")
	  ("MailLists" (id-info "(hyperbole.info)Mail Lists")
	   "Details on Hyperbole mail list subscriptions.")
	  ("New"          (progn
			    (hact 'link-to-regexp-match
				  "\\*[ \t]+What's New" 2
				  (expand-file-name "README" hyperb:dir))
			    (setq buffer-read-only nil)
			    (toggle-read-only))
	   "Recent changes to Hyperbole.")
	  ("SmartKy"      (find-file-read-only (hypb:mouse-help-file))
	   "Summarizes Smart Key mouse or keyboard handling.")
	  ("Types/"       (menu . types)
	   "Provides documentation on Hyperbole types.")
	 ))
       '(ebut .
	 (("EButton>")
	  ("Act"    hui:hbut-act
	    "Activates button at point or prompts for explicit button.")
	  ("Create" hui:ebut-create)
	  ("Delete" hui:ebut-delete)
	  ("Edit"   hui:ebut-modify "Modifies any desired button attributes.")
	  ("Help/"  (menu . ebut-help) "Summarizes button attributes.")
	  ("Info"
	   (id-info "(hyperbole.info)Explicit Buttons")
	   "Displays manual section on explicit buttons.")
	  ("Modify" hui:ebut-modify "Modifies any desired button attributes.")
	  ("Rename" hui:ebut-rename "Relabels an explicit button.")
	  ("Search" hui:ebut-search
	   "Locates and displays personally created buttons in context.")
	  ))
       '(ebut-help .
	 (("Help on>")
	  ("BufferButs"   (hui:hbut-report -1)
	   "Summarizes all explicit buttons in buffer.")
	  ("CurrentBut"   (hui:hbut-report)
	   "Summarizes only current button in buffer.")
	  ("OrderedButs"  (hui:hbut-report 1)
	   "Summarizes explicit buttons in lexicographically order.")
	  ))
       '(gbut .
	 (("GButton>")
	  ("Act"    gbut:act        "Activates global button by name.") 
	  ("Create" hui:gbut-create "Adds a global button to gbut:file.")
	  ("Edit"   hui:gbut-modify "Modifies global button attributes.")
	  ("Help"   gbut:help       "Reports on a global button by name.") 
	  ("Info"   (id-info "(hyperbole.info)Global Buttons")
	   "Displays manual section on global buttons.")
	  ("Modify" hui:gbut-modify "Modifies global button attributes.")
	  ))
       '(ibut .
	 (("IButton>")
	  ("Act"    hui:hbut-act    "Activates implicit button at point.") 
	  ("DeleteIButType"   (hui:htype-delete 'ibtypes)
	   "Deletes specified button type.")
	  ("Help"   hui:hbut-help   "Reports on button's attributes.")
	  ("Info"   (id-info "(hyperbole.info)Implicit Buttons")
	   "Displays manual section on implicit buttons.")
	  ("Types"  (hui:htype-help 'ibtypes 'no-sort)
	   "Displays documentation for one or all implicit button types.")
	  ))
       '(msg .
	 (("Msg>")
	  ("Compose-Hypb-Mail"
	   (hmail:compose "hyperbole-users@gnu.org" '(hact 'hyp-config))
	   "Send a message to the Hyperbole discussion list.")
	  ("Bug-Report"
	   (hmail:compose "bug-hyperbole@gnu.org" '(hact 'hyp-config))
	   "Send a bug report")
	  ("List-Admin" (menu . mailadm)
	   "Administer subscription to the mail lists.")
	  ))
       (if hyperb:kotl-p
	   '(otl
	     . (("Otl>")
		("All"       kotl-mode:show-all "Expand all collapsed cells.") 
		("Blanks"    kvspec:toggle-blank-lines
		 "Toggle blank lines between cells on or off.")
		("Create"    kfile:find   "Create or edit an outline file.")
		("Downto"    kotl-mode:hide-sublevels
		 "Hide all cells in outline deeper than a particular level.")
		("Examp"   (find-file-read-only
			      (expand-file-name
			       "EXAMPLE.kotl" (concat hyperb:dir "kotl/")))
		 "Display a self-descriptive example outline file.")
		("Hide"      (progn (kotl-mode:is-p)
				    (kotl-mode:hide-tree (kcell-view:label)))
		 "Collapse tree rooted at point.")
		("Info"
		 (id-info "(hyperbole.info)Outliner")
		 "Display manual section on Hyperbole outliner.")
		("Kill"      kotl-mode:kill-tree
		 "Kill ARG following trees starting from point.")
		("Link"      klink:create
		 "Create and insert an implicit link at point.")
		("Overvw"  kotl-mode:overview
		 "Show first line of each cell.")
		("Show"      (progn (kotl-mode:is-p)
				    (kotl-mode:show-tree (kcell-view:label)))
		 "Expand tree rooted at point.")
		("Top"       kotl-mode:top-cells
		 "Hide all but top-level cells.") 
		("Vspec"     kvspec:activate
		 "Prompt for and activate a view specifiction.")
		)))
       '(rolo .
	 (("Rolo>")
	  ("Add"              rolo-add	  "Add a new rolo entry.")
	  ("Display"          rolo-display-matches
	   "Display last found rolodex matches again.")
	  ("Edit"             rolo-edit   "Edit an existing rolo entry.")
	  ("Info"             (id-info "(hyperbole.info)Rolodex")
	   "Displays manual section on Hyperbole rolodex.")
	  ("Kill"             rolo-kill   "Kill an existing rolo entry.")
	  ("Mail"             rolo-mail-to "Mail to address following point.")
	  ("Order"            rolo-sort   "Order rolo entries in a file.")
	  ("RegexFind"        rolo-grep   "Find entries containing a regexp.")
	  ("StringFind"       rolo-fgrep  "Find entries containing a string.")
	  ("WordFind"         rolo-word   "Find entries containing words.")
	  ("Yank"             rolo-yank
	   "Find an entry containing a string and insert it at point.")
	  ))
       '(types .
	 (("Types>")
	  ("ActionTypes"      (hui:htype-help   'actypes)
	   "Displays documentation for one or all action types.")
	  ("IButTypes"        (hui:htype-help   'ibtypes 'no-sort)
	   "Displays documentation for one or all implicit button types.")
	  ))
       '(win .
	 (("WinConfig>")
	  ("AddName"        wconfig-add-by-name
	   "Name current window configuration.")
	  ("DeleteName"     wconfig-delete-by-name
	   "Delete named window configuration.")
	  ("RestoreName"    wconfig-restore-by-name
	   "Restore frame to window configuration given by name.")
	  ("PopRing"        (progn (wconfig-delete-pop)
				   (hyperbole 'win))
	   "Restores window configuration from ring and removes it from ring.")
	  ("SaveRing"       (wconfig-ring-save)
	   "Saves current window configuration to ring.")
	  ("YankRing"       (progn (call-interactively 'wconfig-yank-pop)
				   (hyperbole 'win))
	   "Restores next window configuration from ring.")
	  ))
       '(mailadm .
         (("MailAdmin>")
	  ("Hyperbole-Users-Adm"
	   (browse-url "http://lists.gnu.org/mailman/listinfo/hyperbole-users")
	   "Point web browser to administrative interface")
	  ("Bug-Hypberbole-Adm"
	   (browse-url "http://lists.gnu.org/mailman/listinfo/bug-hyperbole")
	   "Point web browser to administrative interface")
          ))
       )))

;;;
;;; Public functions
;;;

;;; Old name
(fset 'hui:menu 'hyperbole)

;;; Used as autoloaded main entry point to Hyperbole (but hsite.el) is the
;;; file that is autoloaded when this is invoked.
;;; It brings up a menu of commands. 
(defun hyperbole (&optional menu menu-list)
  "Invokes default Hyperbole menu user interface when not already active.
Suitable for binding to a key, e.g. {C-h h}.
Non-interactively, returns t if menu is actually invoked by call, else nil.

Two optional arguments may be given to invoke alternative menus.
MENU (a symbol) specifies the menu to invoke from MENU-LIST, (a
Hyperbole menu list structure).  MENU defaults to 'hyperbole and MENU-LIST
to `hui:menus'.  See `hui:menus' definition for the format of the menu list
structure."

  (interactive)
  (if (and hui:menu-p (> (minibuffer-depth) 0))
      (progn (beep) nil)
    (unwind-protect
	(progn
	  (require 'hsite) ;; Since "hui-mini" may be loaded without loading
			   ;; all of Hyperbole.
	  (if hyperbole-on-menubar (hyperb:init-menubar))
	  (setq hui:menu-p t)
	  (hui:menu-act (or menu 'hyperbole) menu-list)
	  t)
      (setq hui:menu-p nil))))

(defun hui:menu-act (menu &optional menu-list)
  "Prompts user with Hyperbole MENU (a symbol) and performs selected item.
Optional second argument MENU-LIST is a Hyperbole menu list structure from
which to extract MENU.  It defaults to `hui:menus'.  See its definition for
the menu list structure." 
  (let ((set-menu '(or (and menu (symbolp menu)
			    (setq menu-alist
				  (cdr (assq menu (or menu-list hui:menus)))))
		       (hypb:error "(menu-act): Invalid menu symbol arg: %s"
			      menu)))
	(show-menu t)
	(rtn)
	menu-alist act-form)
    (while (and show-menu (eval set-menu))
      (cond ((and (consp (setq act-form (hui:menu-select menu-alist)))
		  (cdr act-form)
		  (symbolp (cdr act-form)))
	     ;; Display another menu
	     (setq menu (cdr act-form)))
	    (act-form
	     (let ((prefix-arg current-prefix-arg))
	       (cond ((symbolp act-form)
		      (if (eq act-form t)
			  nil
			(setq show-menu nil
			      rtn (call-interactively act-form))))
		     ((stringp act-form)
		      (hui:menu-help act-form)
		      ;; Loop and show menu again.
		      )
		     (t (setq show-menu nil
			      rtn (eval act-form))))))
	    (t (setq show-menu nil))))
    rtn))

(defun hui:menu-enter (&optional char-str)
  "Uses CHAR-STR or last input character as minibuffer argument."
  (interactive)
  (let ((input (or char-str (aref (recent-keys) (1- (length (recent-keys)))))))
    (cond (hyperb:emacs19-p
	   (and (not (integerp input))
		(eventp input)
		(setq input (event-basic-type input))))
	  (hyperb:xemacs-p
	   (if (eventp input)
	       (setq input (event-to-character input)))))
    (if (or (symbolp input)
	    (and (integerp input)
		 (= input ?\r)))
	(setq input (hargs:at-p)))
    (erase-buffer)
    (or (symbolp input) (insert input)))
  (exit-minibuffer))

(defun hui:menu-help (help-str)
  "Displays HELP-STR in a small window.  HELP-STR must be a string."
  (let* ((window-min-height 2)
	 (owind (selected-window))
	 (buf-name (hypb:help-buf-name "Menu")))
    (unwind-protect
	(progn
	  (save-window-excursion
	    (hkey-help-show buf-name)) ;; Needed to save wconfig.
	  (if (eq (selected-window) (minibuffer-window))
	      (other-window 1))
	  (if (= (length (hypb:window-list 'no-mini)) 1)
	      (split-window-vertically nil))
	  (select-window (hui:bottom-window))
	  (switch-to-buffer (get-buffer-create buf-name))
	  (setq buffer-read-only nil)
	  (erase-buffer)
	  (insert "\n" help-str)
	  (set-buffer-modified-p nil)
	  (shrink-window
	   (- (window-height)
	      (+ 3 (length
		    (delq nil
			  (mapcar (function
				   (lambda (chr) (= chr ?\n)))
				  help-str)))))))
      (select-window owind))))

(defun hui:menu-xemacs (&optional menu menu-list)
  "Returns an XEmacs menu built from Hyperbole type menus.
Optional MENU (a symbol) specifies a specific submenu of optional MENU-LIST.
a Hyperbole menu list structure.  Otherwise, all menus are used.
MENU defaults to 'hyperbole and MENU-LIST to `hui:menus'.  See `hui:menus'
definition for the format of the menu list structure."
  (mapcar
   (function 
    (lambda (entry)
      (or (consp entry) 
	  (error "(hui:menu-xemacs): Invalid menu entry: %s" entry))
      (let ((label (car entry))
	    (content (car (cdr entry))))
	(cond ((null content) (hypb:replace-match-string ">$" label "" t))
	      ((and (consp content) (eq (car content) 'menu))
	       (hui:menu-xemacs (cdr content)))
	      (t (vector label content 't))))))
   (cdr (assq (or menu 'hyperbole) (or menu-list hui:menus)))))

(defun hui:menu-select (menu-alist)
  "Prompts user to choose the first character of any item from MENU-ALIST.
Case is not significant.  If chosen by direct selection with the Assist Key,
returns any help string for item, else returns the action form for the item."
  (let* ((menu-line (hui:menu-line menu-alist))
	 (set:equal-op 'eq)
	 (select-char (string-to-char hui:menu-select))
	 (quit-char (string-to-char hui:menu-quit))
	 (abort-char (string-to-char hui:menu-abort))
	 (top-char  (string-to-char hui:menu-top))
	 (item-keys (mapcar (function
			     (lambda (item) (aref item 0)))
			    (mapcar 'car (cdr menu-alist))))
	 (keys (apply 'list select-char quit-char abort-char
		      top-char item-keys))
	 (key 0)
	 (hargs:reading-p 'hmenu)
	 sublist)
    (while (not (memq (setq key (upcase
				 (string-to-char
				  (read-from-minibuffer
				   "" menu-line hui:menu-mode-map))))
		      keys))
      (beep)
      (setq hargs:reading-p 'hmenu)
      (discard-input))
    (cond ((eq key quit-char) nil)
	  ((eq key abort-char) (beep) nil)
	  ((eq key top-char) '(menu . hyperbole))
	  ((and (eq key select-char)
		(save-excursion
		  (if (search-backward " " nil t)
		      (progn (skip-chars-forward " ")
			     (setq key (following-char))
			     nil)  ;; Drop through.
		    t))))
	  (t (if (setq sublist (memq key item-keys))
		 (let* ((label-act-help-list
			 (nth (- (1+ (length item-keys)) (length sublist))
			      menu-alist))
			(act-form (car (cdr label-act-help-list))))
		   (if (eq hargs:reading-p 'hmenu-help)
		       (let ((help-str
			      (or (car (cdr (cdr label-act-help-list)))
				  "No help documentation for this item.")))
			 (concat (car label-act-help-list) "\n  "
				 help-str "\n    Action: "
				 (prin1-to-string act-form)))
		     act-form)))))))

;;;
;;; Private functions
;;;

(if (fboundp 'window-lowest-p)
    (defun hui:bottom-window ()
      "Return a window that is at the bottom of the selected frame."
      (let ((winds (hypb:window-list 'no-mini))
	    (window))
	(while (and (not window) winds)
	  (if (window-lowest-p (car winds))
	      (setq window (car winds))
	    (setq winds (cdr winds))))
	window))
  (defun hui:bottom-window ()
    "Return a window that is at the bottom of the selected frame."
    (let* ((winds (hypb:window-list 'no-mini))
	   (bot-list (mapcar
		      (function
		       (lambda (wind)
			 (nth 3 (window-edges wind))))
		      winds))
	   (bot (apply 'max bot-list)))
      (nth (- (length winds) (length (memq bot bot-list))) winds))))

(defun hui:menu-line (menu-alist)
  "Returns a menu line string built from MENU-ALIST."
  (let ((menu-prompt (concat (car (car menu-alist)) "  "))
	(menu-items (mapconcat 'car (cdr menu-alist) "  "))
	menu-line)
    (setq menu-line (concat menu-prompt menu-items))
    ;; Narrow menu by changing 2 spaces to 1 if too wide for current frame.
    (if (>= (length menu-line) (1- (frame-width)))
	(concat menu-prompt (mapconcat 'car (cdr menu-alist) " "))
      menu-line)))

;;;
;;; Private variables
;;;

;; Hyperbole menu mode is suitable only for specially formatted data.
(put 'hui:menu-mode 'mode-class 'special)

(defvar hui:menu-mode-map nil
  "Keymap containing hui:menu commands.")
(if hui:menu-mode-map
    nil
  (setq hui:menu-mode-map (make-keymap))
  (suppress-keymap hui:menu-mode-map)
  (define-key hui:menu-mode-map hui:menu-quit   'hui:menu-enter)
  (define-key hui:menu-mode-map hui:menu-abort  'hui:menu-enter)
  (define-key hui:menu-mode-map hui:menu-top    'hui:menu-enter)
  (define-key hui:menu-mode-map hui:menu-select 'hui:menu-enter)
  ;;
  ;; This next binding is necessary since the default button1 binding under
  ;; XEmacs, mouse-track, is broken under XEmacs V19.8.
  (and hyperb:xemacs-p window-system
       (define-key hui:menu-mode-map 'button1 'mouse-set-point))
  (let ((i 32))
    (while (<= i 126)
      (define-key hui:menu-mode-map (char-to-string i) 'hui:menu-enter)
      (setq i (1+ i)))))

(provide 'hui-mini)

;;; hui-mini.el ends here