;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface.

;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
;; Copyright (C) 1995 Sun Microsystems.
;; Copyright (C) 1996 Ben Wing.

;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
;; Keywords: lisp, tools, help, docs, matching

;; This file is part of XEmacs.

;; XEmacs 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 of the License, or
;; (at your option) any later version.
;; 
;; XEmacs 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 XEmacs; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Synched up with: Not in FSF.

;;; Commentary:

;;  based upon emacs-apropos.el by Frank C. Guida <fcg@philabs.philips.com>
;;
;;  Rather than run apropos and print all the documentation at once,
;;  I find it easier to view a "table of contents" first, then
;;  get the details for symbols as you need them.
;;
;;  This version of apropos prints two lists of symbols matching the
;;  given regexp:  functions/macros and variables/constants.
;;
;;  The user can then do the following:
;;
;;      - add an additional regexp to narrow the search
;;      - display documentation for the current symbol
;;      - find the tag for the current symbol
;;      - show any keybindings if the current symbol is a command
;;	- invoke functions
;;	- set variables
;;
;;  An additional feature is the ability to search the current tags
;;  table, allowing you to interrogate functions not yet loaded (this
;;  isn't available with the standard package).
;;
;;  Mouse bindings and menus are provided for XEmacs.
;;
;; additions by Ben Wing <wing@666.com> July 1995:
;; added support for function aliases, made programmer's apropos be the
;; default, various other hacking.
;; Massive changes by Christoph Wedler <wedler@fmi.uni-passau.de>
;; Some changes for XEmacs 20.3 by hniksic

;;; Code:

(require 'pp)

(defgroup hyper-apropos nil
  "Hypertext emacs lisp documentation interface."
  :prefix "hypropos-"
  :group 'docs
  :group 'lisp
  :group 'tools
  :group 'help
  :group 'matching)

;;;###autoload
(defcustom hypropos-show-brief-docs t
  "*If non-nil, `hyper-apropos' will display some documentation in the
\"*Hyper Apropos*\" buffer.  Setting this to nil will speed up searches."
  :type 'boolean
  :group 'hyper-apropos)

;; I changed this to true because I think it's more useful this way. --ben

(defcustom hypropos-programming-apropos t
  "*If non-nil, then `hyper-apropos' takes a bit longer and generates more
output.  If nil, then only functions that are interactive and variables that
are user variables are found by `hyper-apropos'."
  :type 'boolean
  :group 'hyper-apropos)

(defcustom hypropos-shrink-window nil
  "*If non-nil, shrink *Hyper Help* buffer if possible."
  :type 'boolean
  :group 'hyper-apropos)

(defcustom hypropos-prettyprint-long-values t
  "*If non-nil, then try to beautify the printing of very long values."
  :type 'boolean
  :group 'hyper-apropos)


(defgroup hypropos-faces nil
  "Faces defined by hyper-apropos."
  :prefix "hypropos-"
  :group 'hyper-apropos)


(defface hypropos-documentation '((((class color) (background light))
				   (:foreground "darkred"))
				  (((class color) (background dark))
				   (:foreground "gray90")))
  "Hyper-apropos documentation."
  :group 'hypropos-faces)

(defface hypropos-hyperlink '((((class color) (background light))
			       (:foreground "blue4"))
			      (((class color) (background dark))
			       (:foreground "lightseagreen"))
			      (t
			       (:bold t)))
  "Hyper-apropos hyperlinks."
  :group 'hypropos-faces)

(defface hypropos-major-heading '((t (:bold t)))
  "Hyper-apropos major heading."
  :group 'hypropos-faces)

(defface hypropos-section-heading '((t (:bold t :italic t)))
  "Hyper-apropos section heading."
  :group 'hypropos-faces)

(defface hypropos-heading '((t (:bold t)))
  "Hyper-apropos heading."
  :group 'hypropos-faces)

(defface hypropos-warning '((t (:bold t :foreground "red")))
  "Hyper-apropos warning."
  :group 'hypropos-faces)


;;; Internal variables below this point

(defvar hypropos-ref-buffer)
(defvar hypropos-prev-wconfig)

(defvar hypropos-help-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    (set-keymap-name map 'hypropos-help-map)
    ;; movement
    (define-key map " "     'scroll-up)
    (define-key map "b"     'scroll-down)
    (define-key map [delete] 'scroll-down)
    (define-key map [backspace] 'scroll-down)
    (define-key map "/"     'isearch-forward)
    (define-key map "?"     'isearch-backward)
    ;; follow links
    (define-key map [return] 'hypropos-get-doc)
    (define-key map "s"     'hypropos-set-variable)
    (define-key map "t"     'hypropos-find-tag)
    (define-key map "l"     'hypropos-last-help)
    (define-key map "c"     'hypropos-customize-variable)
    (define-key map [button2] 'hypropos-mouse-get-doc)
    (define-key map [button3] 'hypropos-popup-menu)
    ;; for the totally hardcore...
    (define-key map "D"     'hypropos-disassemble)
    ;; administrativa
    (define-key map "a"     'hyper-apropos)
    (define-key map "n"     'hyper-apropos)
    (define-key map "q"     'hypropos-quit)
    map)
  "Keybindings for both the *Hyper Help* buffer and the *Hyper Apropos* buffer")

(defvar hypropos-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-name map 'hypropos-map)
    (set-keymap-parents map (list hypropos-help-map))
    ;; slightly different scrolling...
    (define-key map " "     'hypropos-scroll-up)
    (define-key map "b"     'hypropos-scroll-down)
    (define-key map [delete] 'hypropos-scroll-down)
    (define-key map [backspace] 'hypropos-scroll-down)
    ;; act on the current line...
    (define-key map "w"     'hypropos-where-is)
    (define-key map "i"     'hypropos-invoke-fn)
    (define-key map "s"     'hypropos-set-variable)
    ;; more administrativa...
    (define-key map "P"     'hypropos-toggle-programming-flag)
    (define-key map "k"     'hypropos-add-keyword)
    (define-key map "e"     'hypropos-eliminate-keyword)
    map)
  "Keybindings for the *Hyper Apropos* buffer.
This map inherits from `hypropos-help-map.'")

;;(defvar hypropos-mousable-keymap
;;  (let ((map (make-sparse-keymap)))
;;    (define-key map [button2] 'hypropos-mouse-get-doc)
;;    map))

(defvar hyper-apropos-mode-hook nil
  "*User function run after hyper-apropos mode initialization.  Usage:
\(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).")

;; ---------------------------------------------------------------------- ;;

(defconst hypropos-junk-regexp "^Apropos\\|^Functions\\|^Variables\\|^$")

(defvar hypropos-currently-showing nil)	; symbol documented in help buffer now
(defvar hypropos-help-history nil)	; chain of symbols followed as links in
					; help buffer
(defvar hypropos-face-history nil)
;;;(defvar hypropos-variable-history nil)
;;;(defvar hypropos-function-history nil)
(defvar hypropos-regexp-history nil)
(defvar hypropos-last-regexp nil)	; regex used for last apropos
(defconst hypropos-apropos-buf "*Hyper Apropos*")
(defconst hypropos-help-buf "*Hyper Help*")

;;;###autoload
(defun hyper-apropos (regexp toggle-apropos)
  "Display lists of functions and variables matching REGEXP
in buffer \"*Hyper Apropos*\".  If optional prefix arg is given, then the value
of `hypropos-programming-apropos' is toggled for this search.
See also `hyper-apropos-mode'."
  (interactive (list (read-from-minibuffer "List symbols matching regexp: "
					   nil nil nil 'hypropos-regexp-history)
		     current-prefix-arg))
  (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
      (setq hypropos-prev-wconfig (current-window-configuration)))
  (if (string= "" regexp)
      (if (get-buffer hypropos-apropos-buf)
	  (if toggle-apropos
	      (hypropos-toggle-programming-flag)
	    (message "Using last search results"))
	(error "Be more specific..."))
    (set-buffer (get-buffer-create hypropos-apropos-buf))
    (setq buffer-read-only nil)
    (erase-buffer)
    (if toggle-apropos
	(set (make-local-variable 'hypropos-programming-apropos)
	     (not (default-value 'hypropos-programming-apropos))))
    (let ((flist (apropos-internal regexp
				   (if hypropos-programming-apropos
				       #'fboundp
				     #'commandp)))
	  (vlist (apropos-internal regexp
				   (if hypropos-programming-apropos
				       #'boundp
				     #'user-variable-p))))
      (insert-face (format "Apropos search for: %S\n\n" regexp)
		   'hypropos-major-heading)
      (insert-face "* = command (M-x) or user-variable.\n"
		   'hypropos-documentation)
      (insert-face "\
a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n"
		   'hypropos-documentation)
      (insert-face "Functions and Macros:\n\n" 'hypropos-major-heading)
      (hypropos-grok-functions flist)
      (insert-face "\n\nVariables and Constants:\n\n" 'hypropos-major-heading)
      (hypropos-grok-variables vlist)
      (goto-char (point-min))))
  (switch-to-buffer hypropos-apropos-buf)
  (hyper-apropos-mode regexp))

(defun hypropos-toggle-programming-flag ()
  (interactive)
  (eval-in-buffer hypropos-apropos-buf
    (set (make-local-variable 'hypropos-programming-apropos)
	 (not hypropos-programming-apropos)))
  (message "Re-running apropos...")
  (hyper-apropos hypropos-last-regexp nil))

(defun hypropos-grok-functions (fns)
  (let (bind doc type)
    (dolist (fn fns)
      (setq bind (symbol-function fn)
	    type (cond ((subrp bind) ?i)
		       ((compiled-function-p bind) ?b)
		       ((consp bind) (or (cdr
					  (assq (car bind) '((autoload . ?a)
							     (lambda . ?l)
							     (macro . ?m))))
					 ??))
		       (t ?\ )))
      (insert type (if (commandp fn) "* " "  "))
      (let ((e (insert-face (format "%S" fn) 'hypropos-hyperlink)))
	(set-extent-property e 'mouse-face 'highlight))
      (insert-char ?\  (let ((l (- 30 (length (format "%S" fn)))))
			 (if (natnump l) l 0)))
      (and hypropos-show-brief-docs
	   (setq doc (documentation fn))
	   (insert-face (if doc
			    (concat " - "
				    (substring doc 0 (string-match "\n" doc)))
			  " Not documented.")
			'hypropos-documentation))
      (insert ?\n))))

(defun hypropos-grok-variables (vars)
  (let (doc userp)
    (dolist (var vars)
      (setq userp (user-variable-p var))
      (insert (if userp " * " "   "))
      (let ((e (insert-face (format "%S" var) 'hypropos-hyperlink)))
	(set-extent-property e 'mouse-face 'highlight))
      (insert-char ?\  (let ((l (- 30 (length (format "%S" var)))))
			 (if (natnump l) l 0)))
      (and hypropos-show-brief-docs
	   (setq doc (documentation-property var 'variable-documentation))
	   (insert-face (if doc
			    (concat " - " (substring doc (if userp 1 0)
						     (string-match "\n" doc)))
			  " - Not documented.")
			'hypropos-documentation))
      (insert ?\n))))

;; ---------------------------------------------------------------------- ;;

(defun hyper-apropos-mode (regexp)
  "Improved apropos mode for displaying Emacs documentation.  Function and
variable names are displayed in the buffer \"*Hyper Apropos*\".  

Functions are preceded by a single character to indicates their types:
    a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.
Interactive functions are also preceded by an asterisk.
Variables are preceded by an asterisk if they are user variables.

General Commands:

  	SPC	- scroll documentation or apropos window forward
  	  b	- scroll documentation or apropos window backward
	  k     - eliminate all hits that don't contain keyword
	  n	- new search
  	  /	- isearch-forward
  	  q	- quit and restore previous window configuration
  
  Operations for Symbol on Current Line:
  
      	RET 	- toggle display of symbol's documentation
		  (also on button2 in xemacs)
  	  w     - show the keybinding if symbol is a command
  	  i	- invoke function on current line
  	  s	- set value of variable on current line
	  t	- display the C or lisp source (find-tag)"
  (delete-other-windows)
  (setq mode-name "Hyper-Apropos"
	major-mode 'hyper-apropos-mode
	buffer-read-only t
	truncate-lines t
	hypropos-last-regexp regexp
	modeline-buffer-identification
	(list (cons modeline-buffer-id-left-extent "Hyper Apropos: ")
	      (cons modeline-buffer-id-right-extent (concat "\"" regexp "\""))))
  (use-local-map hypropos-map)
  (run-hooks 'hyper-apropos-mode-hook))

;; ---------------------------------------------------------------------- ;;

;; similar to `describe-key-briefly', copied from prim/help.el by CW

;;;###autoload
(defun hyper-describe-key (key)
  (interactive "kDescribe key: ")
  (hyper-describe-key-briefly key t))

;;;###autoload
(defun hyper-describe-key-briefly (key &optional show)
  (interactive "kDescribe key briefly: \nP")
  (let (menup defn interm final msg)
    (setq defn (key-or-menu-binding key 'menup))    
    (if (or (null defn) (integerp defn))
        (or (numberp show) (message "%s is undefined" (key-description key)))
      (cond ((stringp defn)
	     (setq interm defn
		   final (key-binding defn)))
	    ((vectorp defn)
	     (setq interm (append defn nil))
	     (while (and interm
			 (member (key-binding (vector (car interm)))
				 '(universal-argument digit-argument)))
	       (setq interm (cdr interm)))
	     (while (and interm
			 (not (setq final (key-binding (vconcat interm)))))
	       (setq interm (butlast interm)))
	     (if final
		 (setq interm (vconcat interm))
	       (setq interm defn 
		     final (key-binding defn)))))
      (setq msg (format
		 "%s runs %s%s%s"
		 ;; This used to say 'This menu item' but it could also
		 ;; be a scrollbar event.  We can't distinguish at the
		 ;; moment.
		 (if menup "This item" (key-description key))
		 ;;(if (symbolp defn) defn (key-description defn))
		 (if (symbolp defn) defn (prin1-to-string defn))
		 (if final (concat ", " (key-description interm) " runs ") "")
		 (if final
		     (if (symbolp final) final (prin1-to-string final))
		   "")))
      (if (numberp show)
	  (or (not (symbolp defn))
	      (memq (symbol-function defn)
		    '(zkey-init-kbd-macro zkey-init-kbd-fn))
	      (progn (princ msg) (princ "\n")))
	(message "%s" msg)
	(if final (setq defn final))
	(if (and (or (symbolp defn) (symbolp (setq defn (car-safe defn))))
		 defn
		 show)
	    (hypropos-get-doc defn t))))))

;;;###autoload
(defun hyper-describe-face (symbol &optional this-ref-buffer)
  "Describe face..
See also `hyper-apropos' and `hyper-describe-function'."
  ;; #### - perhaps a prefix arg should suppress the prompt...
  (interactive
   (let (v val)
     (setq v (hypropos-this-symbol))	; symbol under point
     (or (find-face v)
	 (setq v (variable-at-point)))
     (setq val (let ((enable-recursive-minibuffers t))
                 (completing-read
		  (concat (if (hypropos-follow-ref-buffer current-prefix-arg)
			      "Follow face"
			    "Describe face")
			  (if v
			      (format " (default %s): " v)
			    ": "))
		  (mapcar (function (lambda (x) (list (symbol-name x))))
			  (face-list))
		  nil t nil 'hypropos-face-history)))
     (list (if (string= val "")
	       (progn (push (symbol-name v) hypropos-face-history) v)
	     (intern-soft val))
	   current-prefix-arg)))
  (if (null symbol)
      (message "Sorry, nothing to describe.")
    (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
	(setq hypropos-prev-wconfig (current-window-configuration)))
    (hypropos-get-doc symbol t nil this-ref-buffer)))

;;;###autoload
(defun hyper-describe-variable (symbol &optional this-ref-buffer)
  "Hypertext drop-in replacement for `describe-variable'.
See also `hyper-apropos' and `hyper-describe-function'."
  ;; #### - perhaps a prefix arg should suppress the prompt...
  (interactive (list (hypropos-read-variable-symbol
		      (if (hypropos-follow-ref-buffer current-prefix-arg)
			  "Follow variable"
			"Describe variable"))
		     current-prefix-arg))
  (if (null symbol)
      (message "Sorry, nothing to describe.")
    (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
	(setq hypropos-prev-wconfig (current-window-configuration)))
    (hypropos-get-doc symbol t nil this-ref-buffer)))

(defun hyper-where-is (symbol)
  "Print message listing key sequences that invoke specified command."
  (interactive (list (hypropos-read-function-symbol "Where is function")))
  (if (null symbol)
      (message "Sorry, nothing to describe.")
    (where-is symbol)))

;;;###autoload
(defun hyper-describe-function (symbol &optional this-ref-buffer)
  "Hypertext replacement for `describe-function'.  Unlike `describe-function'
in that the symbol under the cursor is the default if it is a function.
See also `hyper-apropos' and `hyper-describe-variable'."
  ;; #### - perhaps a prefix arg should suppress the prompt...
  (interactive (list (hypropos-read-function-symbol
		      (if (hypropos-follow-ref-buffer current-prefix-arg)
			  "Follow function"
			"Describe function"))
		     current-prefix-arg))
  (if (null symbol)
      (message "Sorry, nothing to describe.")
    (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
	(setq hypropos-prev-wconfig (current-window-configuration)))
    (hypropos-get-doc symbol t nil this-ref-buffer)))

;;;###autoload
(defun hypropos-read-variable-symbol (prompt &optional predicate)
  "Hypertext drop-in replacement for `describe-variable'.
See also `hyper-apropos' and `hyper-describe-function'."
  ;; #### - perhaps a prefix arg should suppress the prompt...
  (or predicate (setq predicate 'boundp))
  (let (v val)
    (setq v (hypropos-this-symbol))	; symbol under point
    (or (funcall predicate v)
	(setq v (variable-at-point)))
    (or (funcall predicate v)
	(setq v nil))
    (setq val (let ((enable-recursive-minibuffers t))
		(completing-read
		 (concat prompt
			 (if v
			     (format " (default %s): " v)
			   ": "))
		 obarray predicate t nil 'variable-history)))
    (if (string= val "")
	(progn (push (symbol-name v) variable-history) v)
      (intern-soft val))))

(defun hypropos-read-function-symbol (prompt)
  "Read function symbol from minibuffer."
  (let ((fn (hypropos-this-symbol))
	val)
    (or (fboundp fn)
	(setq fn (function-called-at-point)))
    (setq val (let ((enable-recursive-minibuffers t))
		(completing-read (if fn
				     (format "%s (default %s): " prompt fn)
				   (format "%s: " prompt))
				 obarray 'fboundp t nil
				 'function-history)))
    (if (equal val "")
	(progn (push (symbol-name fn) function-history) fn)
      (intern-soft val))))

(defun hypropos-last-help (arg)
  "Go back to the last symbol documented in the *Hyper Help* buffer."
  (interactive "P")
  (let ((win (get-buffer-window hypropos-help-buf)))
    (or arg (setq arg (if win 1 0)))
    (cond ((= arg 0))
	  ((<= (length hypropos-help-history) arg)
	   ;; go back as far as we can...
	   (setcdr (nreverse hypropos-help-history) nil))
	  (t
	   (setq hypropos-help-history (nthcdr arg hypropos-help-history))))
    (if (or win (> arg 0))
	(hypropos-get-doc (car hypropos-help-history) t)
      (display-buffer hypropos-help-buf))))

(defun hypropos-insert-face (string &optional face)
  "Insert STRING and fontify some parts with face `hypropos-hyperlink'."
  (let ((beg (point)) end)
    (insert-face string (or face 'hypropos-documentation))
    (setq end (point))
    (goto-char beg)
    (while (re-search-forward
	    "`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'"
	    end 'limit)
      (let ((e (make-extent (match-beginning 1) (match-end 1))))
	(set-extent-face e 'hypropos-hyperlink)
	(set-extent-property e 'mouse-face 'highlight))
    (goto-char beg)
    (while (re-search-forward
	    "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)"
	    end 'limit)
      (let ((e (make-extent (match-beginning 1) (match-end 1))))
	(set-extent-face e 'hypropos-hyperlink)
	(set-extent-property e 'mouse-face 'highlight))))))

(defun hypropos-insert-keybinding (keys string)
  (if keys
      (insert "  (" string " bound to \""
	      (mapconcat 'key-description
			 (sort* keys #'< :key #'length)
			 "\", \"")
	      "\")\n")))

(defun hypropos-insert-section-heading (alias-desc &optional desc)
  (or desc (setq desc alias-desc
		 alias-desc nil))
  (if alias-desc
      (setq desc (concat alias-desc
			 (if (memq (aref desc 0)
				   '(?a ?e ?i ?o ?u))
			     ", an " ", a ")
			 desc)))
  (aset desc 0 (upcase (aref desc 0))) ; capitalize
  (goto-char (point-max))
  (newline 3) (delete-blank-lines) (newline 2)
  (hypropos-insert-face desc 'hypropos-section-heading))

(defun hypropos-insert-value (string symbol val)
  (insert-face string 'hypropos-heading)
  (insert (if (symbol-value symbol)
	      (if (or (null val) (eq val t) (integerp val))
		  (prog1
		      (symbol-value symbol)
		    (set symbol nil))
		"see below")
	    "is void")))

(defun hypropos-follow-ref-buffer (this-ref-buffer) 
  (and (not this-ref-buffer)
       (eq major-mode 'hyper-help-mode)
       hypropos-ref-buffer
       (buffer-live-p hypropos-ref-buffer)))

(defun hypropos-get-alias (symbol alias-p next-symbol &optional use)
  "Return (TERMINAL-SYMBOL . ALIAS-DESC)."
  (let (aliases)
    (while (funcall alias-p symbol)
      (setq aliases (cons (if use (funcall use symbol) symbol) aliases))
      (setq symbol (funcall next-symbol symbol)))
    (cons symbol
	  (and aliases
	       (concat "an alias for `"
		       (mapconcat 'symbol-name
				  (nreverse aliases)
				  "',\nwhich is an alias for `")
		       "'")))))

;;;###autoload
(defun hypropos-get-doc (&optional symbol force type this-ref-buffer)
  ;; #### - update this docstring
  "Toggle display of documentation for the symbol on the current line."
  ;; SYMBOL is the symbol to document.  FORCE, if non-nil, means to
  ;; regenerate the documentation even if it already seems to be there.  And
  ;; TYPE, if present, forces the generation of only variable documentation
  ;; or only function documentation.  Normally, if both are present, then
  ;; both will be generated.
  ;;
  ;; TYPES TO IMPLEMENT: obsolete face
  ;;
  (interactive)
  (or symbol
      (setq symbol (hypropos-this-symbol)))
  (or type
      (setq type '(function variable face)))
  (if (and (eq hypropos-currently-showing symbol)
	   (get-buffer hypropos-help-buf)
	   (get-buffer-window hypropos-help-buf)
	   (not force))
      ;; we're already displaying this help, so toggle its display.
      (delete-windows-on hypropos-help-buf)
    ;; OK, we've got to refresh and display it...
    (or (eq symbol (car hypropos-help-history))
	(setq hypropos-help-history
	      (if (eq major-mode 'hyper-help-mode)
		  ;; if we're following a link in the help buffer, then
		  ;; record that in the help history.
		  (cons symbol hypropos-help-history)
		;; otherwise clear the history because it's a new search.
		(list symbol))))
    (save-excursion
      (if (hypropos-follow-ref-buffer this-ref-buffer)
	  (set-buffer hypropos-ref-buffer)
	(setq hypropos-ref-buffer (current-buffer)))
      (let (standard-output
	    ok beg
	    newsym symtype doc obsolete
	    (local mode-name)
	    global local-str global-str
	    font fore back undl
	    aliases alias-desc desc)
	(save-excursion
	  (set-buffer (get-buffer-create hypropos-help-buf))
	  ;;(setq standard-output (current-buffer))
	  (setq buffer-read-only nil)
	  (erase-buffer)
	  (insert-face (format "`%s'" symbol) 'hypropos-major-heading)
	  (insert (format " (buffer: %s, mode: %s)\n"
			  (buffer-name hypropos-ref-buffer)
			  local)))
	;; function ----------------------------------------------------------
	(and (memq 'function type)
	     (fboundp symbol)
	     (progn
	       (setq ok t)
	       (setq aliases (hypropos-get-alias (symbol-function symbol)
						 'symbolp
						 'symbol-function)
		     newsym (car aliases)
		     alias-desc (cdr aliases))
	       (if (eq 'macro (car-safe newsym))
		   (setq desc "macro"
			 newsym (cdr newsym))
		 (setq desc "function"))
	       (setq symtype (cond ((subrp newsym)                   'subr)
				   ((compiled-function-p newsym)     'bytecode)
				   ((eq (car-safe newsym) 'autoload) 'autoload)
				   ((eq (car-safe newsym) 'lambda)   'lambda))
		     desc (concat (if (commandp symbol) "interactive ")
				  (cdr (assq symtype
					     '((subr     . "built-in ")
					       (bytecode . "compiled Lisp ")
					       (autoload . "autoloaded Lisp ")
					       (lambda   . "Lisp "))))
				  desc
				  (if (eq symtype 'autoload)
				      (format ", (autoloaded from \"%s\")"
				      (nth 1 newsym))))
		     local (current-local-map)
		     global (current-global-map)
		     obsolete (get symbol 'byte-obsolete-info)
		     doc (or (documentation symbol) "function not documented"))
	       (save-excursion
		 (set-buffer hypropos-help-buf)
		 (goto-char (point-max))
		 (setq standard-output (current-buffer))
		 (hypropos-insert-section-heading alias-desc desc)
		 (insert ":\n")
		 (if local
		     (hypropos-insert-keybinding
		      (where-is-internal symbol (list local) nil nil nil)
		      "locally"))
		 (hypropos-insert-keybinding
		  (where-is-internal symbol (list global) nil nil nil)
		  "globally")
		 (insert "\n")
		 (if obsolete
		     (hypropos-insert-face
		      (format "%s is an obsolete function; %s\n\n" symbol
			      (if (stringp (car obsolete))
				  (car obsolete)
				(format "use `%s' instead." (car obsolete))))
		      'hypropos-warning))
		 (setq beg (point))
		 (insert-face "arguments: " 'hypropos-heading)
		 (cond ((eq symtype 'lambda)
			(princ (or (nth 1 newsym) "()")))
		       ((eq symtype 'bytecode)
			(princ (or (aref newsym 0) "()")))
		       ((and (eq symtype 'subr)
			     (string-match
			      "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
			      doc))
			(insert (substring doc
					   (match-beginning 1)
					   (match-end 1)))
			(setq doc (substring doc 0 (match-beginning 0))))
		       ((and (eq symtype 'subr)
			     (string-match
			      "\
\[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
			      doc))
			(insert "("
				(if (match-end 1)
				    (substring doc
					       (match-beginning 1)
					       (match-end 1)))
				")")
			(setq doc (substring doc (match-end 0))))
		       (t (princ "[not available]")))
		 (insert "\n\n")
		 (hypropos-insert-face doc)
		 (insert "\n")
		 (indent-rigidly beg (point) 2))))
	;; variable ----------------------------------------------------------
	(and (memq 'variable type)
	     (or (boundp symbol) (default-boundp symbol))
	     (progn 
	       (setq ok t)
	       (setq aliases (hypropos-get-alias symbol
						 'variable-alias
						 'variable-alias
						 'variable-alias)
		     newsym (car aliases)
		     alias-desc (cdr aliases))
	       (setq symtype (or (local-variable-p newsym (current-buffer))
				 (and (local-variable-p newsym
							(current-buffer) t)
				      'auto-local))
		     desc (concat (and (get newsym 'custom-type)
				       "customizable ")
				  (if (user-variable-p newsym)
				      "user variable"
				    "variable")
				  (cond ((eq symtype t) ", buffer-local")
					((eq symtype 'auto-local)
					 ", local when set")))
		     local (and (boundp newsym)
				(symbol-value newsym))
		     local-str (and (boundp newsym)
				    (prin1-to-string local))
		     global (and (eq symtype t)
				 (default-boundp newsym)
				 (default-value newsym))
		     global-str (and (eq symtype t)
				     (default-boundp newsym)
				     (prin1-to-string global))
		     obsolete (get symbol 'byte-obsolete-variable)
		     doc (or (documentation-property symbol
						     'variable-documentation)
			     "variable not documented"))
	       (save-excursion
		 (set-buffer hypropos-help-buf)
		 (goto-char (point-max))
		 (setq standard-output (current-buffer))
		 (hypropos-insert-section-heading alias-desc desc)
		 (when (and (user-variable-p newsym)
			    (get newsym 'custom-type))
		   (let ((e (make-extent (point-at-bol) (point))))
		     (set-extent-property e 'mouse-face 'highlight)
		     (set-extent-property e 'help-echo
					  (format "Customize %s" newsym))
		     (set-extent-property
		      e 'hypropos-custom
		      `(lambda () (customize-variable (quote ,newsym))))))
		 (insert ":\n\n")
		 (setq beg (point))
		 (if obsolete
		     (hypropos-insert-face
		      (format "%s is an obsolete function; %s\n\n" symbol
			      (if (stringp obsolete)
				  obsolete
				(format "use `%s' instead." obsolete)))
		      'hypropos-warning))
		 ;; generally, the value of the variable is short and the
		 ;; documentation of the variable long, so it's desirable
		 ;; to see all of the value and the start of the
		 ;; documentation.  Some variables, though, have huge and
		 ;; nearly meaningless values that force you to page
		 ;; forward just to find the doc string.  That is
		 ;; undesirable.
		 (if (and (or (null local-str) (< (length local-str) 69))
			  (or (null global-str) (< (length global-str) 69)))
					; 80 cols.  docstrings assume this.
		     (progn (insert-face "value: " 'hypropos-heading)
			    (insert (or local-str "is void"))
			    (if (eq symtype t)
				(progn
				  (insert "\n")
				  (insert-face "default value: " 'hypropos-heading)
				  (insert (or global-str "is void"))))
			    (insert "\n\n")
			    (hypropos-insert-face doc))
		   (hypropos-insert-value "value: " 'local-str local)
		   (if (eq symtype t)
		       (progn
			 (insert ", ")
			 (hypropos-insert-value "default-value: "
						'global-str global)))
		   (insert "\n\n")
		   (hypropos-insert-face doc)
		   (if local-str
		       (progn
			 (newline 3) (delete-blank-lines) (newline 1)
			 (insert-face "value: " 'hypropos-heading)
			 (if hypropos-prettyprint-long-values
			     (condition-case nil
				 (let ((pp-print-readably nil)) (pprint local))
			       (error (insert local-str)))
			   (insert local-str))))
		   (if global-str
		       (progn
			 (newline 3) (delete-blank-lines) (newline 1)
			 (insert-face "default value: " 'hypropos-heading)
			 (if hypropos-prettyprint-long-values
			     (condition-case nil
				 (let ((pp-print-readably nil)) (pprint global))
			       (error (insert global-str)))
			   (insert global-str)))))
		 (indent-rigidly beg (point) 2))))
	;; face --------------------------------------------------------------
	(and (memq 'face type)
	     (find-face symbol)
	     (progn
	       (setq ok t)
	       (copy-face symbol 'hypropos-temp-face 'global)
	       (mapcar (function
			(lambda (property)
			  (setq symtype (face-property-instance symbol
								property))
			  (if symtype
			      (set-face-property 'hypropos-temp-face
						 property
						 symtype))))
		       built-in-face-specifiers)
	       (setq font (cons (face-property-instance symbol 'font nil 0 t)
				(face-property-instance symbol 'font))
		     fore (cons (face-foreground-instance symbol nil 0 t)
				(face-foreground-instance symbol))
		     back (cons (face-background-instance symbol nil 0 t)
				(face-background-instance symbol))
		     undl (cons (face-underline-p symbol nil 0 t)
				(face-underline-p symbol))
		     doc  (face-doc-string symbol))
	       ;; #### - add some code here
	       (save-excursion
		 (set-buffer hypropos-help-buf)
		 (setq standard-output (current-buffer))
		 (hypropos-insert-section-heading
		  (concat "Face"
			  (when (get symbol 'face-defface-spec)
			    (let* ((str " (customizable)")
				   (e (make-extent 1 (length str) str)))
			      (set-extent-property e 'mouse-face 'highlight)
			      (set-extent-property e 'help-echo
						   (format "Customize %s" symbol))
			      (set-extent-property e 'unique t)
			      (set-extent-property e 'duplicable t)
			      (set-extent-property
			       e 'hypropos-custom
			       `(lambda () (customize-face (quote ,symbol))))
			      str))
			  ":\n\n  "))
		 (insert-face "\
ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789"
			      'hypropos-temp-face)
		 (newline 2)
		 (insert-face "  Font: " 'hypropos-heading)
		 (insert (format (if (numberp (car font)) "(%s)\n" "%s\n")
				 (and (cdr font)
				      (font-instance-name (cdr font)))))
		 (insert-face "  Foreground: " 'hypropos-heading)
		 (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n")
				 (and (cdr fore)
				      (color-instance-name (cdr fore)))))
		 (insert-face "  Background: " 'hypropos-heading)
		 (insert (format (if (numberp (car back)) "(%s)\n" "%s\n")
				 (and (cdr back)
				      (color-instance-name (cdr back)))))
		 (insert-face "  Underline: " 'hypropos-heading)
		 (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n")
				 (cdr undl)))
		 (if doc
		     (progn
		       (newline)
		       (setq beg (point))
		       (insert doc)
		       (indent-rigidly beg (point) 2))))))
	;; not bound & property list -----------------------------------------
	(or ok
	    (save-excursion
	      (set-buffer hypropos-help-buf)
	      (hypropos-insert-section-heading
	       "symbol is not currently bound\n")))
	(if (and (setq symtype (symbol-plist symbol))
		 (or (> (length symtype) 2)
		     (not (memq 'variable-documentation symtype))))
	    (save-excursion
	      (set-buffer hypropos-help-buf)
	      (goto-char (point-max))
	      (setq standard-output (current-buffer))
	      (hypropos-insert-section-heading "property-list:\n\n")
	      (while symtype
		(if (memq (car symtype)
			  '(variable-documentation byte-obsolete-info))
		    (setq symtype (cdr symtype))
		  (insert-face (concat "  " (symbol-name (car symtype))
				       ": ")
			       'hypropos-heading)
		  (setq symtype (cdr symtype))
		  (indent-to 32)
		  (insert (prin1-to-string (car symtype)) "\n"))
		(setq symtype (cdr symtype)))))))
    (save-excursion
      (set-buffer hypropos-help-buf)
      (goto-char (point-min)) 
      ;; pop up window and shrink it if it's wasting space
      (if hypropos-shrink-window
	  (shrink-window-if-larger-than-buffer
	   (display-buffer (current-buffer)))
	(display-buffer (current-buffer)))
      (hyper-help-mode))
    (setq hypropos-currently-showing symbol)))

; -----------------------------------------------------------------------------

(defun hyper-help-mode ()
  "Major mode for hypertext XEmacs help.  In this mode, you can quickly
follow links between back and forth between the documentation strings for
different variables and functions.  Common commands:

\\{hypropos-help-map}"
  (setq buffer-read-only t
	major-mode	     'hyper-help-mode
	mode-name	     "Hyper-Help")
  (set-syntax-table emacs-lisp-mode-syntax-table)
  (hypropos-highlightify)
  (use-local-map hypropos-help-map))

;; ---------------------------------------------------------------------- ;;

(defun hypropos-highlightify ()
  (save-excursion
    (goto-char (point-min))
    (let ((st (point-min))
	  sym)
      (while (not (eobp))
	(if (zerop (skip-syntax-forward "w_"))
	    (forward-char 1)
	  (and (> (- (point) st) 3)
	       (setq sym (intern-soft (buffer-substring st (point))))
	       (or (boundp sym)
		   (fboundp sym))
	       (set-extent-property (make-extent st (point))
				    'mouse-face 'highlight)))
	(setq st (point))))))

;; ---------------------------------------------------------------------- ;;

(defun hypropos-scroll-up ()
  "Scroll up the \"*Hyper Help*\" buffer if it's visible, or scroll this window up."
  (interactive)
  (let ((win (get-buffer-window hypropos-help-buf))
	(owin (selected-window)))
    (if win
	(progn
	  (select-window win)
	  (condition-case nil
	       (scroll-up nil)
	      (error (goto-char (point-max))))
	  (select-window owin))
      (scroll-up nil))))

(defun hypropos-scroll-down ()
  "Scroll down the \"*Hyper Help*\" buffer if it's visible, or scroll this window down."
  (interactive)
  (let ((win (get-buffer-window hypropos-help-buf))
	(owin (selected-window)))
    (if win
	(progn
	  (select-window win)
	  (condition-case nil
	       (scroll-down nil)
	      (error (goto-char (point-max))))
	  (select-window owin))
      (scroll-down nil))))

;; ---------------------------------------------------------------------- ;;

(defun hypropos-mouse-get-doc (event)
  "Get the documentation for the symbol the mouse is on."
  (interactive "e")
  (mouse-set-point event)
  (let ((e (extent-at (point) nil 'hypropos-custom)))
    (if e
	(funcall (extent-property e 'hypropos-custom))
      (save-excursion
	(let ((symbol (hypropos-this-symbol)))
	  (if symbol
	      (hypropos-get-doc symbol)
	    (error "Click on a symbol")))))))

;; ---------------------------------------------------------------------- ;;

(defun hypropos-add-keyword (pattern)
  "Use additional keyword to narrow regexp match.
Deletes lines which don't match PATTERN."
  (interactive "sAdditional Keyword: ")
  (save-excursion
    (goto-char (point-min))
    (let (buffer-read-only)
      (keep-lines (concat pattern "\\|" hypropos-junk-regexp))
      )))

(defun hypropos-eliminate-keyword (pattern)
  "Use additional keyword to eliminate uninteresting matches.
Deletes lines which match PATTERN."
  (interactive "sKeyword to eliminate: ")
  (save-excursion
    (goto-char (point-min))
    (let (buffer-read-only)
      (flush-lines pattern))
      ))

;; ---------------------------------------------------------------------- ;;

(defun hypropos-this-symbol ()
  (save-excursion
    (cond ((eq major-mode 'hyper-apropos-mode)
	   (beginning-of-line)
	   (if (looking-at hypropos-junk-regexp)
	       nil
	     (forward-char 3)
	     (read (point-marker))))
	  (t
	   (let* ((st (progn
			(skip-syntax-backward "w_")
			;; !@(*$^%%# stupid backquote implementation!!!
			(skip-chars-forward "`")
			(point)))
		  (en (progn
			(skip-syntax-forward "w_")
			(skip-chars-backward ".':") ; : for Local Variables
			(point))))
	     (and (not (eq st en))
		  (intern-soft (buffer-substring st en))))))))

(defun hypropos-where-is (symbol)
  "Find keybinding for symbol on current line."
  (interactive (list (hypropos-this-symbol)))
  (where-is symbol))

(defun hypropos-invoke-fn (fn)
  "Interactively invoke the function on the current line."
  (interactive (list (hypropos-this-symbol)))
  (cond ((not (fboundp fn))
	 (error "%S is not a function" fn))
	(t (call-interactively fn))))

;;;###autoload
(defun hyper-set-variable (var val &optional this-ref-buffer)
  (interactive
   (let ((var (hypropos-read-variable-symbol
	       (if (hypropos-follow-ref-buffer current-prefix-arg)
		   "In ref buffer, set user option"
		 "Set user option")
	       'user-variable-p)))
     (list var (hypropos-read-variable-value var) current-prefix-arg)))
  (hypropos-set-variable var val this-ref-buffer))

;;;###autoload
(defun hypropos-set-variable (var val &optional this-ref-buffer)
  "Interactively set the variable on the current line."
  (interactive
   (let ((var (hypropos-this-symbol)))
     (or (and var (boundp var))
	 (and (setq var (and (eq major-mode 'hyper-help-mode)
			     (save-excursion
			       (goto-char (point-min))
			       (hypropos-this-symbol))))
	      (boundp var))
	 (setq var nil))
     (list var (hypropos-read-variable-value var))))
  (and var
       (boundp var)
       (progn
	 (if (hypropos-follow-ref-buffer this-ref-buffer)
	     (save-excursion
	       (set-buffer hypropos-ref-buffer)
	       (set var val))
	   (set var val))
	 (hypropos-get-doc var t '(variable) this-ref-buffer))))

(defun hypropos-read-variable-value (var &optional this-ref-buffer)
  (and var
       (boundp var)
       (let ((prop (get var 'variable-interactive))
	     (print-readably t)
	     val str)
	 (hypropos-get-doc var t '(variable) current-prefix-arg)
	 (if prop
	     (call-interactively (list 'lambda '(arg)
				       (list 'interactive prop)
				       'arg))
	   (setq val (if (hypropos-follow-ref-buffer this-ref-buffer)
			 (save-excursion
			   (set-buffer hypropos-ref-buffer)
			   (symbol-value var))
		       (symbol-value var))
		 str (prin1-to-string val))
	   (eval-minibuffer
	    (format "Set %s `%s' to value (evaluated): "
		    (if (user-variable-p var) "user option" "Variable")
		    var)
	    (condition-case nil
		(progn
		  (read str)
		  (format (if (or (consp val)
				  (and (symbolp val)
				       (not (memq val '(t nil)))))
			      "'%s" "%s")
			  str))
	      (error nil)))))))

(defun hypropos-customize-variable ()
  (interactive)
  (let ((var (hypropos-this-symbol)))
    (customize-variable var)))

;; ---------------------------------------------------------------------- ;;

(defun hypropos-find-tag (&optional tag-name)
  "Find the tag for the symbol on the current line in other window.  In
order for this to work properly, the variable `tag-table-alist' or
`tags-file-name' must be set so that a TAGS file with tags for the emacs
source is found for the \"*Hyper Apropos*\" buffer."
  (interactive)
  ;; there ought to be a default tags file for this...
  (or tag-name (setq tag-name (symbol-name (hypropos-this-symbol))))
  (find-tag-other-window (list tag-name)))

;; ---------------------------------------------------------------------- ;;

(defun hypropos-disassemble (sym)
  "Disassemble FUN if it is byte-coded.  If it's a lambda, prettyprint it."
  (interactive (list (hypropos-this-symbol)))
  (let ((fun sym) (trail nil) macrop)
    (while (and (symbolp fun) (not (memq fun trail)))
      (setq trail (cons fun trail)
	    fun (symbol-function fun)))
    (and (symbolp fun)
	 (error "Loop detected in function binding of `%s'" fun))
    (setq macrop (and  (consp fun)
		       (eq 'macro (car fun))))
    (cond ((compiled-function-p (if macrop (cdr fun) fun))
	   (disassemble fun)
	   (set-buffer "*Disassemble*")
	   (goto-char (point-min))
	   (forward-sexp 2)
	   (insert (format " for function `%S'" sym))
	   )
	  ((consp fun)
	   (with-output-to-temp-buffer "*Disassemble*"
	     (pprint (if macrop
			 (cons 'defmacro (cons sym (cdr (cdr fun))))
		       (cons 'defun (cons sym (cdr fun))))))
	   (set-buffer "*Disassemble*")
	   (emacs-lisp-mode))
	  ((or (vectorp fun) (stringp fun))
	   ;; #### - do something fancy here
	   (with-output-to-temp-buffer "*Disassemble*"
	     (princ (format "%s is a keyboard macro:\n\n\t" sym))
	     (prin1 fun)))
	  (t
	   (error "Sorry, cannot disassemble `%s'" sym)))))

;; ---------------------------------------------------------------------- ;;

(defun hypropos-quit ()
  (interactive)
  "Quit Hyper Apropos and restore original window config."
  (let ((buf (get-buffer hypropos-apropos-buf)))
    (and buf (bury-buffer buf)))
  (set-window-configuration hypropos-prev-wconfig))

;; ---------------------------------------------------------------------- ;;

;;;###autoload
(defun hypropos-popup-menu (event)
  (interactive "e")
  (mouse-set-point event)
  (let* ((sym (hypropos-this-symbol))
	 (notjunk (not (null sym)))
	 (command-p (if (commandp sym) t))
	 (variable-p (and sym (boundp sym)))
	 (customizable-p (and variable-p
			      (get sym 'custom-type)
			      t))
	 (function-p (fboundp sym))
	 (apropos-p (eq 'hyper-apropos-mode
			(save-excursion (set-buffer (event-buffer event))
					major-mode)))
	 (name (if sym (symbol-name sym) ""))
	 (hypropos-menu
	  (delete
	   nil
	   (list (concat "Hyper-Help: " name)
	    (vector "Display documentation" 'hypropos-get-doc   notjunk)
	    (vector "Set variable"	'hypropos-set-variable	variable-p)
	    (vector "Customize variable" 'hypropos-customize-variable
		    customizable-p)
	    (vector "Show keys for"     'hypropos-where-is      command-p)
	    (vector "Invoke command"	'hypropos-invoke-fn	command-p)
	    (vector "Find tag"		'hypropos-find-tag	notjunk)
	    (and apropos-p
		 ["Add keyword..." hypropos-add-keyword	t])
	    (and apropos-p
		 ["Eliminate keyword..." hypropos-eliminate-keyword  t])
	    (if apropos-p
		["Programmers' Apropos" hypropos-toggle-programming-flag
		 :style toggle :selected hypropos-programming-apropos]
	      ["Programmers' Help" hypropos-toggle-programming-flag
	       :style toggle :selected hypropos-programming-apropos])
	    (and hypropos-programming-apropos
		 (vector "Disassemble function"
			 'hypropos-disassemble
			 function-p))
	    ["Help"                     describe-mode           t]
	    ["Quit"			hypropos-quit		t]
	    ))))
    (popup-menu hypropos-menu)))

(provide 'hyper-apropos)

;; end of hyper-apropos.el