;;!emacs
;; $Id:
;;
;; FILE:         hui-menus.el
;; SUMMARY:      One line command menus for Hyperbole
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    15-Oct-91 at 20:13:17
;; LAST-MOD:     21-May-93 at 19:55:41 by Bob Weiner
;;
;; This file is part of Hyperbole.
;; 
;; Copyright (C) 1991, 1992, 1993, Brown University, Providence, RI
;; Developed with support from Motorola Inc.
;; 
;; Permission to use, modify and redistribute this software and its
;; documentation for any purpose other than its incorporation into a
;; commercial product is hereby granted without fee.  A distribution fee
;; may be charged with any redistribution.  Any distribution requires
;; that the above copyright notice appear in all copies, that both that
;; copyright notice and this permission notice appear in supporting
;; documentation, and that neither the name of Brown University nor the
;; author's name be used in advertising or publicity pertaining to
;; distribution of the software without specific, written prior permission.
;; 
;; Brown University makes no representations about the suitability of this
;; software for any purpose.  It is provided "as is" without express or
;; implied warranty.
;;
;;
;; DESCRIPTION:  
;; DESCRIP-END.

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

(require 'hui)

;;; ************************************************************************
;;; Public variables
;;; ************************************************************************

(defvar hui:menu-select "\C-m"
  "*Upper case char-string which select Hyperbole menu item at point.")
(defvar hui:menu-quit   "Q"
  "*Upper case char-string which quits from selecting 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
 (list (cons
	'hyperbole
	(append
	 (list (list (concat "Hypb" hyperb:version ">")))
	 '(("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.")
	   ("Rolo/"       (progn (or (fboundp 'rolo-kill) (require 'wrolo))
				 (hui:menu-act 'rolo))
	    "Hierarchical, multi-file rolodex lookup and edit commands.")
	   ("Types/"      (menu . types)
	    "Provides documentation on Hyperbole types.")
	   )))
       '(butfile .
	 (("Butfile>")
	  ("DirFile"      (find-file hbmap:filename)
	   "Edits directory-specific button file.")
	  ("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"     (hact 'link-to-Info-node "(hypb.info)Glossary")
	   "Glossary of Hyperbole terms.")
	  ("HypbCopy"  (progn
			 (hact 'link-to-string-match "* Copyright" 2
			       (expand-file-name "README" hyperb:dir))
			 (setq buffer-read-only nil)
			 (toggle-read-only))
	   "Displays general Hyperbole copyright and license details.")
	  ("InfoManual"   (hact 'link-to-Info-node "(hypb.info)")
	   "Online Info version of Hyperbole manual.")
	  ("MailLists"    (progn
			    (hact 'link-to-string-match "* Mail Lists" 2
				  (expand-file-name "README" hyperb:dir))
			    (setq buffer-read-only nil)
			    (toggle-read-only))
	   "Details on Hyperbole mail list subscriptions.")
	  ("New"          (progn
			    (hact 'link-to-string-match "* 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
			    (expand-file-name "hmouse-doc.txt" hyperb:dir))
	   "Summarizes Smart Key mouse or keyboard handling.")
	 ))
       '(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.")
	  ("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.")
	  ("Help"   gbut:help       "Reports on a global button by name.") 
	  ))
       '(ibut .
	 (("IButton>")
	  ("Act"    hui:hbut-act    "Activates implicit button at point.") 
	  ("Help"   hui:hbut-help   "Reports on button's attributes.")
	  ("Types"  (hui:htype-help 'ibtypes 'no-sort)
	   "Displays documentation for one or all implicit button types.")
	  ))
       '(msg .
	 (("Msg>")
	  ("Compose-Hypb-Mail"
	   (progn
	     (if (fboundp 'vm-mail) (vm-mail) (mail))
	     (insert "hyperbole@cs.brown.edu")
	     (forward-line 1) (end-of-line)
	     (save-excursion
	       (insert
		"Be explicit here.  Make a statement or ask a question."))
	     (hact 'hyp-config)
	     (message "Edit and then mail."))
	   "Send a message to the Hyperbole discussion list.")
	  ("Edit-Hypb-Mail-List-Entry"
	   (progn (if (fboundp 'vm-mail) (vm-mail) (mail))
		  (insert "hyperbole-request@cs.brown.edu")
		  (forward-line 1) (end-of-line)
		  (hact 'hyp-request)
		  (message "Edit and then mail."))
	   "Add, remove or change your entry on a hyperbole mail list.")
	  ))
       '(rolo .
	 (("Rolo>")
	  ("Add"              rolo-add	  "Add a new rolo entry.")
	  ("DisplayAgain"     rolo-display-matches
	   "Display last found rolodex matches again.")
	  ("Edit"             rolo-edit   "Edit an existing rolo entry.")
	  ("Kill"             rolo-kill   "Kill an existing rolo entry.")
	  ("Order"            rolo-sort   "Order rolo entries in a file.")
	  ("RegexpFind"       rolo-grep   "Find entries containing a regexp.")
	  ("StringFind"       rolo-fgrep  "Find entries containing a string.")
	  ("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.")
	  ("DeleteIButType"   (hui:htype-delete 'ibtypes)
	   "Deletes specified button type.")
	  ("IButTypes"        (hui:htype-help   'ibtypes 'no-sort)
	   "Displays documentation for one or all implicit button types.")
	  ))
       ))

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

(defun hui:menu (&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)
  (condition-case ()
      (if (and hui:menu-p (> (minibuffer-depth) 0))
	  (progn (beep) nil)
	(setq hui:menu-p t)
	(hui:menu-act (or menu 'hyperbole) menu-list)
	(setq hui:menu-p nil)
	t)
    (quit (beep) (message "Quit") (setq hui:menu-p nil))
    (error (setq hui:menu-p nil)
	   (unwind-protect
	       (progn (message (get 'error 'error-message))
		      (beep))
	     (put 'error 'error-message "error")
	     ))))

(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)
  (erase-buffer)
  (let ((input (or char-str (aref (recent-keys) (1- (length (recent-keys)))))))
    (insert 
     (if (and hyperb:lemacs-p (eventp input))
	 (event-to-character input)
       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
	    (smart-key-help-show buf-name)) ;; Needed to save screen config.
	  (if (eq (selected-window) (minibuffer-window))
	      (other-window 1))
	  (if (= (length (hypb:window-list 'no-mini)) 1)
	      (split-window-vertically nil))
	  (let* ((winds (hypb:window-list 'no-mini))
		 (bot-list (mapcar
			    '(lambda (wind)
			       (nth 3 (window-edges wind))) winds))
		 (bot (apply 'max bot-list)))
	    (select-window
	     (nth (- (length winds) (length (memq bot bot-list))) winds)))
	  (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 '(lambda (chr) (= chr ?\n)) help-str)))))))
      (select-window owind))))

(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 secondary
Smart Key, returns any help string for item, else returns the action form for
the item."
  (let* ((menu-prompt (concat (car (car menu-alist)) "  "))
	 (menu-items (mapconcat 'car (cdr 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 '(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
				   "" (concat menu-prompt menu-items)
				   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 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)
  (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-menus)