X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Fhelp.el;h=a337b13e35aa31ad99804d2baa7dd7ab3cf84de8;hp=eb7b1b6c835e16f5e6fa3c6c27d482a31c5c7772;hb=3198ed8319f99e19a14447745f4f93e4b4522961;hpb=77dcef404dc78635f6ffa8f71a803d2bc7cc8921 diff --git a/lisp/help.el b/lisp/help.el index eb7b1b6..a337b13 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -51,7 +51,7 @@ (defvar help-map (let ((map (make-sparse-keymap))) (set-keymap-name map 'help-map) (set-keymap-prompt - map (purecopy (gettext "(Type ? for further options)"))) + map (gettext "(Type ? for further options)")) map) "Keymap for characters following the Help key.") @@ -240,10 +240,8 @@ If the optional argument BURY is non-nil, the help buffer is buried, otherwise it is killed." (interactive) (let ((buf (current-buffer))) - (cond ((frame-property (selected-frame) 'help-window-config) - (set-window-configuration - (frame-property (selected-frame) 'help-window-config)) - (set-frame-property (selected-frame) 'help-window-config nil)) + (cond (help-window-config + (set-window-configuration help-window-config)) ((not (one-window-p)) (delete-window))) (if bury @@ -256,7 +254,7 @@ otherwise it is killed." ;; This is a grody hack of the same genotype as `advertised-undo'; if the ;; bindings of Backspace and C-h are the same, we want the menubar to claim -;; that `info' in invoked with `C-h i', not `BS i'. +;; that `info' is invoked with `C-h i', not `BS i'. (defun deprecated-help-command () (interactive) @@ -305,8 +303,8 @@ otherwise it is killed." "Return the command invoked by KEY. Like `key-binding', but handles menu events and toolbar presses correctly. KEY is any value returned by `next-command-event'. -MENU-FLAG is a symbol that should be set to T if KEY is a menu event, - or NIL otherwise" +MENU-FLAG is a symbol that should be set to t if KEY is a menu event, + or nil otherwise." (let (defn) (and menu-flag (set menu-flag nil)) ;; If the key typed was really a menu selection, grab the form out @@ -461,7 +459,9 @@ You should never set this directory, only let-bind it.") (if (and (integerp help-max-help-buffers) (> help-max-help-buffers 0) (stringp name)) - (format "*%s: %s*" help-buffer-prefix-string name) + (if help-buffer-prefix-string + (format "*%s: %s*" help-buffer-prefix-string name) + (format "*%s*" name)) (format "*%s*" help-buffer-prefix-string))) ;; Use this function for displaying help when C-h something is pressed @@ -478,6 +478,21 @@ You should never set this directory, only let-bind it.") ;; another name (which is a shame, because w-d-h-b is a perfect name ;; for a macro) that uses with-displaying-help-buffer internally. +(defcustom mode-for-help 'help-mode + "*Mode that help buffers are put into.") + +(defvar help-sticky-window nil +;; Window into which help buffers will be displayed, rather than +;; always searching for a new one. This is INTERNAL and liable to +;; change its interface and/or name at any moment. It should be +;; bound, not set. +) + +(defvar help-window-config nil) + +(make-variable-buffer-local 'help-window-config) +(put 'help-window-config 'permanent-local t) + (defun with-displaying-help-buffer (thunk &optional name) "Form which makes a help buffer with given NAME and evaluates BODY there. The actual name of the buffer is generated by the function `help-buffer-name'." @@ -490,19 +505,28 @@ The actual name of the buffer is generated by the function `help-buffer-name'." (mapcar 'window-frame (windows-of-buffer buffer-name))))))) (help-register-and-maybe-prune-excess buffer-name) - (prog1 (with-output-to-temp-buffer buffer-name - (prog1 (funcall thunk) - (save-excursion - (set-buffer standard-output) - (help-mode)))) + ;; if help-sticky-window is bogus or deleted, get rid of it. + (if (and help-sticky-window (or (not (windowp help-sticky-window)) + (not (window-live-p help-sticky-window)))) + (setq help-sticky-window nil)) + (prog1 + (let ((temp-buffer-show-function + (if help-sticky-window + #'(lambda (buffer) + (set-window-buffer help-sticky-window buffer)) + temp-buffer-show-function))) + (with-output-to-temp-buffer buffer-name + (prog1 (funcall thunk) + (save-excursion + (set-buffer standard-output) + (funcall mode-for-help))))) (let ((helpwin (get-buffer-window buffer-name))) (when helpwin - (with-current-buffer (window-buffer helpwin) - ;; If the *Help* buffer is already displayed on this - ;; frame, don't override the previous configuration - (when help-not-visible - (set-frame-property (selected-frame) - 'help-window-config winconfig))) + ;; If the *Help* buffer is already displayed on this + ;; frame, don't override the previous configuration + (when help-not-visible + (with-current-buffer (window-buffer helpwin) + (setq help-window-config winconfig))) (when help-selects-help-window (select-window helpwin)) (cond ((eq helpwin (selected-window)) @@ -639,10 +663,10 @@ describes the minor mode." (defun describe-bindings (&optional prefix mouse-only-p) "Show a list of all defined keys, and their definitions. The list is put in a buffer, which is displayed. -If the optional argument PREFIX is supplied, only commands which -start with that sequence of keys are described. -If the second argument (prefix arg, interactively) is non-null -then only the mouse bindings are displayed." +If optional first argument PREFIX is supplied, only commands +which start with that sequence of keys are described. +If optional second argument MOUSE-ONLY-P (prefix arg, interactively) +is non-nil then only the mouse bindings are displayed." (interactive (list nil current-prefix-arg)) (with-displaying-help-buffer (lambda () @@ -655,9 +679,20 @@ then only the mouse bindings are displayed." (gettext "key binding\n--- -------\n"))) (buffer (current-buffer)) (minor minor-mode-map-alist) + (extent-maps (mapcar-extents + 'extent-keymap + nil (current-buffer) (point) (point) nil 'keymap)) (local (current-local-map)) (shadow '())) (set-buffer standard-output) + (while extent-maps + (insert "Bindings for Text Region:\n" + heading) + (describe-bindings-internal + (car extent-maps) nil shadow prefix mouse-only-p) + (insert "\n") + (setq shadow (cons (car extent-maps) shadow) + extent-maps (cdr extent-maps))) (while minor (let ((sym (car (car minor))) (map (cdr (car minor)))) @@ -717,7 +752,10 @@ of the key sequence that ran this command." (stringp Installation-string)) (with-displaying-help-buffer (lambda () - (princ Installation-string)) + (princ + (if (fboundp 'decode-coding-string) + (decode-coding-string Installation-string 'automatic-conversion) + Installation-string))) "Installation") (error "No Installation information available."))) @@ -729,16 +767,15 @@ of the key sequence that ran this command." (defun xemacs-www-page () "Go to the XEmacs World Wide Web page." (interactive) - (if (boundp 'browse-url-browser-function) - (funcall browse-url-browser-function "http://www.xemacs.org/") + (if (fboundp 'browse-url) + (browse-url "http://www.xemacs.org/") (error "xemacs-www-page requires browse-url"))) (defun xemacs-www-faq () "View the latest and greatest XEmacs FAQ using the World Wide Web." (interactive) - (if (boundp 'browse-url-browser-function) - (funcall browse-url-browser-function - "http://www.xemacs.org/faq/index.html") + (if (fboundp 'browse-url) + (browse-url "http://www.xemacs.org/faq/index.html") (error "xemacs-www-faq requires browse-url"))) (defun xemacs-local-faq () @@ -846,7 +883,7 @@ The number of messages shown is controlled by `view-lossage-message-count'." help-map) (defmacro with-syntax-table (syntab &rest body) - "Evaluate BODY with the syntax-table SYNTAB" + "Evaluate BODY with the SYNTAB as the current syntax table." `(let ((stab (syntax-table))) (unwind-protect (progn @@ -906,6 +943,21 @@ list containing point. If that doesn't give a function, return nil." (setq obj (read (current-buffer))) (and (symbolp obj) (fboundp obj) obj))))))) +(defun function-at-event (event) + "Return the function whose name is around the position of EVENT. +EVENT should be a mouse event. When calling from a popup or context menu, +use `last-popup-menu-event' to find out where the mouse was clicked. +\(You cannot use (interactive \"e\"), unfortunately. This returns a +misc-user event.) + +If the event contains no position, or the position is not over text, or +there is no function around that point, nil is returned." + (if (and event (event-buffer event) (event-point event)) + (save-excursion + (set-buffer (event-buffer event)) + (goto-char (event-point event)) + (function-at-point)))) + ;; Default to nil for the non-hackers? Not until we find a way to ;; distinguish hackers from non-hackers automatically! (defcustom describe-function-show-arglist t @@ -935,8 +987,9 @@ When run interactively, it defaults to any function found by (format (gettext "Describe function (default %s): ") fn) (gettext "Describe function: ")) - obarray 'fboundp t nil 'function-history)))) - (list (if (equal val "") fn (intern val))))) + obarray 'fboundp t nil 'function-history + (symbol-name fn))))) + (list (intern val)))) (with-displaying-help-buffer (lambda () (describe-function-1 function) @@ -1004,24 +1057,27 @@ For example: This function is used by `describe-function-1' to list function arguments in the standard Lisp style." - (let* ((fndef (indirect-function function)) + (let* ((fnc (indirect-function function)) + (fndef (if (eq (car-safe fnc) 'macro) + (cdr fnc) + fnc)) (arglist - (cond ((compiled-function-p fndef) - (compiled-function-arglist fndef)) - ((eq (car-safe fndef) 'lambda) - (nth 1 fndef)) - ((subrp fndef) - (let* ((doc (documentation function)) - (args (and (string-match - "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" - doc) - (match-string 1 doc)))) - ;; If there are no arguments documented for the - ;; subr, rather don't print anything. - (cond ((null args) t) - ((equal args "") nil) - (args)))) - (t t)))) + (cond ((compiled-function-p fndef) + (compiled-function-arglist fndef)) + ((eq (car-safe fndef) 'lambda) + (nth 1 fndef)) + ((subrp fndef) + (let* ((doc (documentation function)) + (args (and (string-match + "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" + doc) + (match-string 1 doc)))) + ;; If there are no arguments documented for the + ;; subr, rather don't print anything. + (cond ((null args) t) + ((equal args "") nil) + (args)))) + (t t)))) (cond ((listp arglist) (prin1-to-string (cons function (mapcar (lambda (arg) @@ -1045,6 +1101,119 @@ part of the documentation of internal subroutines." (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc)) (setq doc (substring doc 0 (match-beginning 0)))) doc)) +; (let ((name-char "[-+a-zA-Z0-9_*]") (sym-char "[-+a-zA-Z0-9_:*]")) +; (list +; ;; +; ;; The symbol itself. +; (list (concat "\\`\\(" name-char "+\\)\\(:\\)?") +; '(1 (if (match-beginning 2) +; 'font-lock-function-name-face +; 'font-lock-variable-name-face) +; nil t)) +; ;; +; ;; Words inside `' which tend to be symbol names. +; (list (concat "`\\(" sym-char sym-char "+\\)'") +; 1 '(prog1 +; 'font-lock-reference-face +; (add-list-mode-item (match-beginning 1) +; (match-end 1) +; nil +; 'help-follow-reference)) +; t) +; ;; +; ;; CLisp `:' keywords as references. +; (list (concat "\\<:" sym-char "+\\>") 0 'font-lock-reference-face t))) + +(defvar help-symbol-regexp + (let ((sym-char "[+a-zA-Z0-9_:*]") + (sym-char-no-dash "[-+a-zA-Z0-9_:*]")) + (concat "\\(" + ;; a symbol with a - in it. + "\\<\\(" sym-char-no-dash "+\\(-" sym-char-no-dash "+\\)+\\)\\>" + "\\|" + "`\\(" sym-char "+\\)'" + "\\)"))) + +(defun help-symbol-run-function-1 (ev ex fun) + (let ((help-sticky-window + ;; if we were called from a help buffer, make sure the new help + ;; goes in the same window. + (if (and (event-buffer ev) + (symbol-value-in-buffer 'help-window-config + (event-buffer ev))) + (event-window ev) + help-sticky-window))) + (funcall fun (extent-property ex 'help-symbol)))) + +(defun help-symbol-run-function (fun) + (let ((ex (extent-at-event last-popup-menu-event 'help-symbol))) + (when ex + (help-symbol-run-function-1 last-popup-menu-event ex fun)))) + +(defvar help-symbol-function-context-menu + '("---" + ["View %_Documentation" (help-symbol-run-function 'describe-function)] + ["Find %_Function Source" (help-symbol-run-function 'find-function)] + )) + +(defvar help-symbol-variable-context-menu + '("---" + ["View %_Documentation" (help-symbol-run-function 'describe-variable)] + ["Find %_Variable Source" (help-symbol-run-function 'find-variable)] + )) + +(defvar help-symbol-function-and-variable-context-menu + '("---" + ["View Function %_Documentation" (help-symbol-run-function + 'describe-function)] + ["View Variable D%_ocumentation" (help-symbol-run-function + 'describe-variable)] + ["Find %_Function Source" (help-symbol-run-function 'find-function)] + ["Find %_Variable Source" (help-symbol-run-function 'find-variable)] + )) + +(defun frob-help-extents (buffer) + ;; Look through BUFFER, starting at the buffer's point and continuing + ;; till end of file, and find documented functions and variables. + ;; any such symbol found is tagged with an extent, that sets up these + ;; properties: + ;; 1. mouse-face is 'highlight (so the extent gets highlighted on mouse over) + ;; 2. help-symbol is the name of the symbol. + ;; 3. context-menu is a list of context menu items, specific to whether + ;; the symbol is a function, variable, or both. + ;; 4. activate-function will cause the function or variable to be described, + ;; replacing the existing help contents. + (save-excursion + (set-buffer buffer) + (let (b e name) + (while (re-search-forward help-symbol-regexp nil t) + (setq b (or (match-beginning 2) (match-beginning 4))) + (setq e (or (match-end 2) (match-end 4))) + (setq name (buffer-substring b e)) + (let* ((sym (intern-soft name)) + (var (and sym (boundp sym) + (documentation-property sym + 'variable-documentation t))) + (fun (and sym (fboundp sym) + (documentation sym t)))) + (when (or var fun) + (let ((ex (make-extent b e))) + (set-extent-property ex 'mouse-face 'highlight) + (set-extent-property ex 'help-symbol sym) + (set-extent-property + ex 'context-menu + (cond ((and var fun) + help-symbol-function-and-variable-context-menu) + (var help-symbol-variable-context-menu) + (fun help-symbol-function-context-menu))) + (set-extent-property + ex 'activate-function + (if fun + #'(lambda (ev ex) + (help-symbol-run-function-1 ev ex 'describe-function)) + #'(lambda (ev ex) + (help-symbol-run-function-1 ev ex 'describe-variable)))) + ))))))) ;; 11 parentheses! (defun describe-function-1 (function &optional nodoc) "This function does the work for `describe-function'." @@ -1141,7 +1310,13 @@ part of the documentation of internal subroutines." (unless (and obsolete aliases) (let ((doc (function-documentation function t))) (princ "Documentation:\n") - (princ doc) + (let ((oldp (point standard-output)) + newp) + (princ doc) + (setq newp (point standard-output)) + (goto-char oldp standard-output) + (frob-help-extents standard-output) + (goto-char newp standard-output)) (unless (or (equal doc "") (eq ?\n (aref doc (1- (length doc))))) (terpri))))))))) @@ -1155,7 +1330,6 @@ part of the documentation of internal subroutines." (message nil) (message (function-arglist function))) - (defun variable-at-point () (ignore-errors (with-syntax-table emacs-lisp-mode-syntax-table @@ -1168,6 +1342,21 @@ part of the documentation of internal subroutines." (let ((obj (read (current-buffer)))) (and (symbolp obj) (boundp obj) obj)))))) +(defun variable-at-event (event) + "Return the variable whose name is around the position of EVENT. +EVENT should be a mouse event. When calling from a popup or context menu, +use `last-popup-menu-event' to find out where the mouse was clicked. +\(You cannot use (interactive \"e\"), unfortunately. This returns a +misc-user event.) + +If the event contains no position, or the position is not over text, or +there is no variable around that point, nil is returned." + (if (and event (event-buffer event) (event-point event)) + (save-excursion + (set-buffer (event-buffer event)) + (goto-char (event-point event)) + (variable-at-point)))) + (defun variable-obsolete-p (variable) "Return non-nil if VARIABLE is obsolete." (not (null (get variable 'byte-obsolete-variable)))) @@ -1224,8 +1413,9 @@ part of the documentation of internal subroutines." (if v (format "Describe variable (default %s): " v) (gettext "Describe variable: ")) - obarray 'boundp t nil 'variable-history)))) - (list (if (equal val "") v (intern val))))) + obarray 'boundp t nil 'variable-history + (symbol-name v))))) + (list (intern val)))) (with-displaying-help-buffer (lambda () (let ((origvar variable) @@ -1295,7 +1485,13 @@ part of the documentation of internal subroutines." (when (or (not obsolete) (not aliases)) (if doc ;; note: documentation-property calls substitute-command-keys. - (princ doc) + (let ((oldp (point standard-output)) + newp) + (princ doc) + (setq newp (point standard-output)) + (goto-char oldp standard-output) + (frob-help-extents standard-output) + (goto-char newp standard-output)) (princ "not documented as a variable.")))) (terpri))) (format "variable `%s'" variable))) @@ -1321,7 +1517,8 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." val) (setq val (read-command (if fn (format "Where is command (default %s): " fn) - "Where is command: "))) + "Where is command: ") + (and fn (symbol-name fn)))) (list (if (equal (symbol-name val) "") fn val) current-prefix-arg))) @@ -1408,7 +1605,7 @@ after the listing is made.)" (if cmd (princ " "))))) (terpri)))))) -;; Stop gap for 21.0 untill we do help-char etc properly. +;; Stop gap for 21.0 until we do help-char etc properly. (defun help-keymap-with-help-key (keymap form) "Return a copy of KEYMAP with an help-key binding according to help-char invoking FORM like help-form. An existing binding is not overridden. @@ -1428,5 +1625,4 @@ after the listing is made.)" (with-displaying-help-buffer (insert string))))) - ;;; help.el ends here