xemacs-beta: lisp/packages/hyper-apropos.el comparison

comparison lisp/packages/hyper-apropos.el @ 30:ec9a17fef872 r19-15b98

Import from CVS: tag r19-15b98

author	cvs
date	Mon, 13 Aug 2007 08:52:29 +0200
parents	0293115a14e9
children	8d2a9b52c682

comparison

equal deleted inserted replaced

-:7976500f47f9
+:ec9a17fef872
 ;;  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>
 ;;; Code:
 (or (fboundp 'pprint)
 (progn (autoload 'pp "pp")
 ;;;###autoload
 (defvar 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.")
+(defvar hypropos-shrink-window nil
+"*If non-nil, shrink *Hyper Help* buffer if possible.")
 (defvar hypropos-prettyprint-long-values t
 "*If non-nil, then try to beautify the printing of very long values.")
 ;; I changed this to true because I think it's more useful this way. --ben
 (defvar 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'.")
+(defvar hypropos-ref-buffer)
 (defvar hypropos-prev-wconfig)
 ;; #### - move this to subr.el
 (or (fboundp 'event-buffer)
 (defun event-buffer (event)
 "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 differrent scrolling...
+		       ;; slightly different scrolling...
 		       (define-key map " "     'hypropos-scroll-up)
 		       (define-key map "b"     'hypropos-scroll-down)
 		       ;; act on the current line...
 		       (define-key map "w"     'hypropos-where-is)
 		       (define-key map "i"     'hypropos-invoke-fn)
 (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 "sList symbols matching regexp: \nP")
+(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
 	 (not hypropos-programming-apropos)))
 (message "Re-running apropos...")
 (hyper-apropos hypropos-last-regexp nil))
 (defun hypropos-grok-functions (fns)
-(let (fn bind type)
+(let (fn bind doc type)
 (while (setq fn (car fns))
 (setq bind (symbol-function fn)
 	    type (cond ((subrp bind) ?i)
 		       ((compiled-function-p bind) ?b)
 		       ((consp bind) (or (cdr
 					 ??))
 		       (t ? )))
 (insert type (if (commandp fn) "* " "  "))
 (insert-face (format "%-30S" fn) 'hyperlink)
 (and hypropos-show-brief-docs
-	   (if (function-obsolete-p fn)
+	   (setq doc (documentation fn))
-	       (insert-face " - Obsolete." 'documentation)
+	   (insert-face (if doc
-	     (let ((doc (documentation fn)))
+			    (concat " - "
-	       (if (not doc)
+				    (substring doc 0 (string-match "\n" doc)))
-		   (insert-face " - Not documented." 'documentation)
+			  " Not documented.")
-		 (insert-face (concat " - "
+			'documentation))
-				      (substring doc 0
-						 (string-match "\n" doc)))
-			      'documentation)))))
 (insert ?\n)
 (setq fns (cdr fns))
 )))
 (defun hypropos-grok-variables (vars)
-(let (var userp)
+(let (var doc userp)
 (while (setq var (car vars))
 (setq userp (user-variable-p var)
 	    vars (cdr vars))
 (insert (if userp " * " "   "))
 (insert-face (format "%-30S" var) 'hyperlink)
 (and hypropos-show-brief-docs
-	   (if (variable-obsolete-p var)
+	   (setq doc (documentation-property var 'variable-documentation))
-	       (insert-face " - Obsolete." 'documentation)
+	   (insert-face (if doc
-	     (let ((doc (documentation-property var 'variable-documentation)))
+			    (concat " - " (substring doc (if userp 1 0)
-	       (if (not doc)
+						     (string-match "\n" doc)))
-		   (insert-face " - Not documented." 'documentation)
+			  " - Not documented.")
-		 (insert-face (concat " - "
+			'documentation))
-				      (substring doc (if userp 1 0)
-						 (string-match "\n" doc)))
-			      'documentation)))))
 (insert ?\n)
 )))
 ;; ---------------------------------------------------------------------- ;;
 (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-variable (symbol)
+(defun hyper-describe-key (key)
-"Hypertext drop-in replacement for `describe-variable'.
+(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 (variable-at-point))
+(let (v val)
-(val (let ((enable-recursive-minibuffers t))
+(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
-		  (if v
+		  (concat (if (hypropos-follow-ref-buffer current-prefix-arg)
-		      (format "Describe variable (default %s): " v)
+			      "Follow face"
-		    "Describe variable: ")
+			    "Describe face")
-		  obarray 'boundp t))))
+			  (if v
-(list (if (string= val "") v (intern-soft val)))))
+			      (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)))
+(hypropos-get-doc symbol t nil this-ref-buffer)))
 ;;;###autoload
-(defun hyper-describe-function (symbol)
+(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
+(interactive (list (hypropos-read-function-symbol
-(let (fn val)
+		      (if (hypropos-follow-ref-buffer current-prefix-arg)
-(setq fn (hypropos-this-symbol))	; symbol under point
+			  "Follow function"
-(or (fboundp fn)
+			"Describe function"))
-	 (setq fn (function-called-at-point)))
+		     current-prefix-arg))
-(setq val (let ((enable-recursive-minibuffers t))
-		 (completing-read
-		  (if fn
-		      (format "Describe function (default %s): " fn)
-		    "Describe function: ")
-		  obarray 'fboundp t)))
-(list (if (equal val "") fn (intern-soft val)))))
 (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)))
+(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))
+(let ((win (get-buffer-window hypropos-help-buf)))
-	(n (prefix-numeric-value arg)))
+(or arg (setq arg (if win 1 0)))
-(cond ((and (not win) (not arg))
+(cond ((= arg 0))
-	   ;; don't alter the help-history, just redisplay
+	  ((<= (length hypropos-help-history) arg)
-	   )
-	  ((<= (length hypropos-help-history) n)
 	   ;; go back as far as we can...
 	   (setcdr (nreverse hypropos-help-history) nil))
 	  (t
-	   (setq hypropos-help-history (nthcdr n hypropos-help-history))))
+	   (setq hypropos-help-history (nthcdr arg hypropos-help-history))))
-(hypropos-get-doc (car hypropos-help-history) t)))
+(if (or win (> arg 0))
+	(hypropos-get-doc (car hypropos-help-history) t)
-(defun hypropos-get-doc (&optional symbol force type)
+(display-buffer hypropos-help-buf))))
+(defun hypropos-insert-face (string &optional face)
+"Insert STRING and fontify some parts with face `hyperlink'."
+(let ((beg (point)) end)
+(insert-face string (or face '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)
+(set-extent-face (make-extent (match-beginning 1) (match-end 1))
+		       'hyperlink))
+(goto-char beg)
+(while (re-search-forward
+	    "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)"
+	    end 'limit)
+(set-extent-face (make-extent (match-beginning 1) (match-end 1))
+		       'hyperlink))))
+(defun hypropos-insert-keybinding (keys string)
+(if keys
+(insert "  (" string " bound to \""
+	      (mapconcat 'key-description
+			 (sort keys #'(lambda (x y)
+					(< (length x) (length y))))
+			 "\", \"")
+	      "\")\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 'section-heading))
+(defun hypropos-insert-value (string symbol val)
+(insert-face string '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
 		  ;; 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
-(set-buffer (get-buffer-create hypropos-help-buf))
+(if (hypropos-follow-ref-buffer this-ref-buffer)
-(setq buffer-read-only nil)
+	  (set-buffer hypropos-ref-buffer)
-(erase-buffer)
+	(setq hypropos-ref-buffer (current-buffer)))
-(let ((standard-output (current-buffer))
+(let (standard-output
-	    ok beg desc
+	    ok beg
-	    ftype macrop fndef
+	    newsym symtype doc obsolete
-	    keys val doc
+	    (local mode-name)
-	    obsolete aliases alias-desc)
+	    global local-str global-str
-	(insert-face (format "`%s'\n\n" symbol) 'major-heading)
+	    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) '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 ok t)
-		     fndef (symbol-function symbol))
+	       (setq aliases (hypropos-get-alias (symbol-function symbol)
-	       (while (symbolp fndef)
+						 'symbolp
-		 (setq aliases (cons fndef aliases))
+						 'symbol-function)
-		 (setq fndef (symbol-function fndef)))
+		     newsym (car aliases)
-	       (if (eq 'macro (car-safe fndef))
+		     alias-desc (cdr aliases))
-		   (setq macrop t
+	       (if (eq 'macro (car-safe newsym))
-			 fndef (cdr fndef)))
+		   (setq desc "macro"
-	       (setq aliases (nreverse aliases))
+			 newsym (cdr newsym))
-	       ;; #### - the gods of internationalization shall strike me down!
+		 (setq desc "function"))
-	       (while aliases
+	       (setq symtype (cond ((subrp newsym)                   'subr)
-		 (if alias-desc
+				   ((compiled-function-p newsym)     'bytecode)
-		     (setq alias-desc (concat alias-desc ",\nwhich is ")))
+				   ((eq (car-safe newsym) 'autoload) 'autoload)
-		 (setq alias-desc (concat alias-desc
+				   ((eq (car-safe newsym) 'lambda)   'lambda))
-					  (format "an alias for `%s'"
-						  (car aliases))))
-		 (setq aliases (cdr aliases)))
-	       (setq ftype (cond ((subrp fndef)                   'subr)
-				 ((compiled-function-p fndef)     'bytecode)
-				 ((eq (car-safe fndef) 'autoload) 'autoload)
-				 ((eq (car-safe fndef) 'lambda)	  'lambda))
 		     desc (concat (if (commandp symbol) "interactive ")
-				  (cdr (assq ftype
+				  (cdr (assq symtype
 					     '((subr     . "built-in ")
 					       (bytecode . "compiled Lisp ")
 					       (autoload . "autoloaded Lisp ")
 					       (lambda   . "Lisp "))))
-				  (if macrop "macro" "function")
+				  desc)
-				  ))
+		     local (current-local-map)
-	       (if alias-desc
+		     global (current-global-map)
-		   (setq desc (concat alias-desc
+		     obsolete (get symbol 'byte-obsolete-info)
-				      (if (memq (aref desc 0)
-						'(?a ?e ?i ?o ?u))
-					  ", an " ", a ")
-				      desc)))
-	       (aset desc 0 (upcase (aref desc 0))) ; capitalize
-	       (insert-face desc 'section-heading)
-	       (and (eq ftype 'autoload)
-		    (insert (format ", (autoloaded from \"%s\")"
-				    (nth 1 fndef))))
-	       ;; #### - should also show local binding in some other
-	       ;; buffer so that this function can be used in place of
-	       ;; describe-function and describe-variable.
-	       (if (setq keys (where-is-internal symbol (current-global-map)
-						 nil nil nil))
-		   (insert (format ", (globally bound to %s)"
-				   (mapconcat
-				    #'(lambda (x)
-					(format "\"%s\""
-						(key-description x)))
-				    (sort keys #'(lambda (x y)
-						   (< (length x) (length y))))
-				    ", "))))
-	       (insert ":\n\n")
-	       (setq beg (point)
 		     doc (or (documentation symbol) "function not documented"))
-	       (insert-face "arguments: " 'heading)
+	       (save-excursion
-	       (cond ((eq ftype 'lambda)
+		 (set-buffer hypropos-help-buf)
-		      (princ (or (nth 1 fndef) "()")))
+		 (goto-char (point-max))
-		     ((eq ftype 'bytecode)
+		 (setq standard-output (current-buffer))
-		      (princ (or (if (fboundp 'compiled-function-arglist)
+		 (hypropos-insert-section-heading alias-desc desc)
-				     (compiled-function-arglist fndef)
+		 (and (eq symtype 'autoload)
-				   (aref fndef 0)) "()")))
+		      (insert (format ", (autoloaded from \"%s\")"
-		     ((and (eq ftype 'subr)
+				      (nth 1 newsym))))
-			   (string-match
+		 (insert ":\n")
-			    "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
+		 (if local
-			    doc))
+		     (hypropos-insert-keybinding
-		      (insert (substring doc
+		      (where-is-internal symbol (list local) nil nil nil)
-					 (match-beginning 1)
+		      "locally"))
-					 (match-end 1)))
+		 (hypropos-insert-keybinding
-		      (setq doc (substring doc 0 (match-beginning 0))))
+		  (where-is-internal symbol (list global) nil nil nil)
-		     (t (princ "[not available]")))
+		  "globally")
-	       (insert "\n\n")
+		 (insert "\n")
-	       (let ((new
+		 (if obsolete
-		      ;; cookbook from bytecomp.el
+		     (hypropos-insert-face
-		      (get symbol 'byte-obsolete-info)))
+		      (format "%s is an obsolete function; %s\n\n" symbol
-		 (and new
+			      (if (stringp (car obsolete))
-		      (insert-face
+				  (car obsolete)
-		       (format "%s is an obsolete function; %s\n\n" symbol
+				(format "use `%s' instead." (car obsolete))))
-			       (if (stringp (car new))
+		      'warning))
-				   (car new)
+		 (setq beg (point))
-				 (format "use %s instead." (car new))))
+		 (insert-face "arguments: " 'heading)
-		       'warning)))
+		 (cond ((eq symtype 'lambda)
-	       (insert-face doc 'documentation)
+			(princ (or (nth 1 newsym) "()")))
-	       (indent-rigidly beg (point) 1)
+		       ((eq symtype 'bytecode)
-	       (insert"\n\n")
+			(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)
-	     (boundp symbol)
+	     (or (boundp symbol) (default-boundp symbol))
 	     (progn
 	       (setq ok t)
-	       (insert-face (if (user-variable-p symbol)
+	       (setq aliases (hypropos-get-alias symbol
-				"User variable"
+						 'variable-alias
-			      "Variable")
+						 'variable-alias
-			    'section-heading)
+						 'variable-alias)
-	       (and (local-variable-p symbol nil t)
+		     newsym (car aliases)
-		    (insert ", local when set"))
+		     alias-desc (cdr aliases))
-	       (insert ":\n\n")
+	       (setq symtype (or (local-variable-p newsym (current-buffer))
-	       (setq beg (point)
+				 (and (local-variable-p newsym
-		     val (prin1-to-string (symbol-value symbol))
+							(current-buffer) t)
-		     doc (or (documentation-property
+				      'auto-local))
-			      symbol 'variable-documentation)
+		     desc (concat (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
-	       (let ((ob (get symbol 'byte-obsolete-variable)))
+		 (set-buffer hypropos-help-buf)
-		 (setq obsolete
+		 (goto-char (point-max))
-		       (and ob (format "%s is an obsolete variable; %s\n\n"
+		 (setq standard-output (current-buffer))
-				       symbol
+		 (hypropos-insert-section-heading alias-desc desc)
-				       (if (stringp ob)
+		 (insert ":\n\n")
-					   ob
+		 (setq beg (point))
-					 (format "use %s instead." ob))))))
+		 (if obsolete
-	       ;; generally, the value of the variable is short and the
+		     (hypropos-insert-face
-	       ;; documentation of the variable long, so it's desirable
+		      (format "%s is an obsolete function; %s\n\n" symbol
-	       ;; to see all of the value and the start of the
+			      (if (stringp obsolete)
-	       ;; documentation.  Some variables, though, have huge and
+				  obsolete
-	       ;; nearly meaningless values that force you to page
+				(format "use `%s' instead." obsolete)))
-	       ;; forward just to find the doc string.  That is
+		      'warning))
-	       ;; undesirable.
+		 ;; generally, the value of the variable is short and the
-	       (if (< (length val) 69)	; 80 cols.  docstrings assume this.
+		 ;; documentation of the variable long, so it's desirable
-		   (progn (insert-face "value: " 'heading)
+		 ;; to see all of the value and the start of the
-			  (insert (format "%s\n\n" val))
+		 ;; documentation.  Some variables, though, have huge and
-			  (and obsolete (insert-face obsolete 'warning))
+		 ;; nearly meaningless values that force you to page
-			  (insert-face doc 'documentation))
+		 ;; forward just to find the doc string.  That is
-		 (insert "(see below for value)\n\n")
+		 ;; undesirable.
-		 (and obsolete (insert-face obsolete 'warning))
+		 (if (and (or (null local-str) (< (length local-str) 69))
-		 (insert-face doc 'documentation)
+			  (or (null global-str) (< (length global-str) 69)))
-		 (insert "\n\n")
+					; 80 cols.  docstrings assume this.
-		 (insert-face "value: " 'heading)
+		     (progn (insert-face "value: " 'heading)
-		 (if hypropos-prettyprint-long-values
+			    (insert (or local-str "is void"))
-		     (let ((pp-print-readably nil))
+			    (if (eq symtype t)
-		       (pprint (symbol-value symbol)))
+				(progn
-		   (insert val)))
+				  (insert "\n")
-	       (indent-rigidly beg (point) 2)
+				  (insert-face "default value: " '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: " '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: " '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
-	       (insert "Face documentation is \"To be implemented.\"\n\n")
+	       (save-excursion
-	       )
+		 (set-buffer hypropos-help-buf)
-	     )
+		 (setq standard-output (current-buffer))
-	(or ok (insert-face "symbol is not currently bound" 'heading)))
+		 (hypropos-insert-section-heading "Face:\n\n  ")
+		 (insert-face "ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789"
+			      'hypropos-temp-face)
+		 (newline 2)
+		 (insert-face "  Font: " 'heading)
+		 (insert (format (if (numberp (car font)) "(%s)\n" "%s\n")
+				 (and (cdr font)
+				      (font-instance-name (cdr font)))))
+		 (insert-face "  Foreground: " 'heading)
+		 (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n")
+				 (and (cdr fore)
+				      (color-instance-name (cdr fore)))))
+		 (insert-face "  Background: " 'heading)
+		 (insert (format (if (numberp (car back)) "(%s)\n" "%s\n")
+				 (and (cdr back)
+				      (color-instance-name (cdr back)))))
+		 (insert-face "  Underline: " '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))
+				       ": ")
+			       '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
-(shrink-window-if-larger-than-buffer
+(if hypropos-shrink-window
-(display-buffer (current-buffer)))
+	  (shrink-window-if-larger-than-buffer
-(hyper-help-mode))    )
+	   (display-buffer (current-buffer)))
-(setq hypropos-currently-showing symbol))
+	(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
 			;; !@(*$^%%# stupid backquote implementation!!!
 			(skip-chars-forward "`")
 			(point)))
 		  (en (progn
 			(skip-syntax-forward "w_")
-			(skip-chars-backward ".")
+			(skip-chars-backward ".':") ; : for Local Variables
 			(point))))
 	     (and (not (eq st en))
 		  (intern-soft (buffer-substring st en))))))))
 (defun hypropos-where-is (symbol)
 (cond ((not (fboundp fn))
 	 (error "%S is not a function" fn))
 	(t (call-interactively fn))))
 ;;;###autoload
-(defun hypropos-set-variable (var val)
+(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 (save-excursion
+(let ((var (hypropos-this-symbol)))
-		(and (eq major-mode 'hypropos-help-mode)
+(or (and var (boundp var))
-		     (goto-char (point-min)))
+	 (and (setq var (and (eq major-mode 'hyper-help-mode)
-		(hypropos-this-symbol))))
+			     (save-excursion
-(or (boundp var)
+			       (goto-char (point-min))
-	 (setq var (completing-read "Set variable: "
+			       (hypropos-this-symbol))))
-				    obarray 'boundp t)))
+	      (boundp var))
-(hypropos-get-doc var t)
+	 (setq var nil))
-(list var
+(list var (hypropos-read-variable-value var))))
-	   (let ((prop (get var 'variable-interactive))
+(and var
-		 (print-readably t)
+(boundp var)
-		 (val (symbol-value var)))
+(progn
-	     (if prop
+	 (if (hypropos-follow-ref-buffer this-ref-buffer)
-		 (call-interactively (list 'lambda '(arg)
+	     (save-excursion
-					   (list 'interactive prop)
+	       (set-buffer hypropos-ref-buffer)
-					   'arg))
+	       (set var val))
-	       (eval-minibuffer
+	   (set var val))
-		(format "Set `%s' to value (evaluated): " var)
+	 (hypropos-get-doc var t '(variable) this-ref-buffer))))
-		(format (if (or (consp val)
-				(and (symbolp val)
+(defun hypropos-read-variable-value (var &optional this-ref-buffer)
-				     (not (memq val '(t nil)))))
+(and var
-			    "'%s" "%s")
+(boundp var)
-			(prin1-to-string val))))))
+(let ((prop (get var 'variable-interactive))
-))
+	     (print-readably t)
-(set var val)
+	     val str)
-(hypropos-get-doc var t))
+	 (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-find-tag (&optional tag-name)
 "Find the tag for the symbol on the current line in other window.  In
 (popup-menu hypropos-menu)))
 (provide 'hyper-apropos)
 ;; end of hyper-apropos.el

Mercurial > hg > xemacs-beta

comparison lisp/packages/hyper-apropos.el @ 30:ec9a17fef872 r19-15b98