help-fns.el 77.9 KB
Newer Older
1
;;; help-fns.el --- Complex help functions -*- lexical-binding: t -*-
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1985-1986, 1993-1994, 1998-2020 Free Software
Paul Eggert's avatar
Paul Eggert committed
4
;; Foundation, Inc.
5

6
;; Maintainer: emacs-devel@gnu.org
7
;; Keywords: help, internal
8
;; Package: emacs
9 10 11 12 13 14 15 16 17 18 19 20 21 22

;; This file is part of GNU Emacs.

;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs 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
23
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
24 25 26 27 28 29 30 31 32 33 34

;;; Commentary:

;; This file contains those help commands which are complicated, and
;; which may not be used in every session.  For example
;; `describe-function' will probably be heavily used when doing elisp
;; programming, but not if just editing C files.  Simpler help commands
;; are in help.el

;;; Code:

35
(require 'cl-lib)
36
(require 'help-mode)
37
(require 'radix-tree)
38
(eval-when-compile (require 'subr-x))   ;For when-let.
39

40 41 42 43
(defvar help-fns-describe-function-functions nil
  "List of functions to run in help buffer in `describe-function'.
Those functions will be run after the header line and argument
list was inserted, and before the documentation will be inserted.
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
The functions will receive the function name as argument.
They can assume that a newline was output just before they were called,
and they should terminate any of their own output with a newline.
By convention they should indent their output by 2 spaces.")

(defvar help-fns-describe-variable-functions nil
  "List of functions to run in help buffer in `describe-variable'.
Those functions will be run after the header line and value was inserted,
and before the documentation will be inserted.
The functions will receive the variable name as argument.
They can assume that a newline was output just before they were called,
and they should terminate any of their own output with a newline.
By convention they should indent their output by 2 spaces.
Current buffer is the buffer in which we queried the variable,
and the output should go to `standard-output'.")
59

60 61 62 63 64 65 66
(defvar help-fns-describe-face-functions nil
  "List of functions to run in help buffer in `describe-face'.
The functions will be used (and take the same parameters) as
described in `help-fns-describe-variable-functions', except that
the functions are called with two parameters: The face and the
frame.")

67 68
;; Functions

69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92
(defvar help-definition-prefixes nil
  ;; FIXME: We keep `definition-prefixes' as a hash-table so as to
  ;; avoid pre-loading radix-tree and because it takes slightly less
  ;; memory.  But when we use this table it's more efficient to
  ;; represent it as a radix tree, since the main operation is to do
  ;; `radix-tree-prefixes'.  Maybe we should just bite the bullet and
  ;; use a radix tree for `definition-prefixes' (it's not *that*
  ;; costly, really).
  "Radix-tree representation replacing `definition-prefixes'.")

(defun help-definition-prefixes ()
  "Return the up-to-date radix-tree form of `definition-prefixes'."
  (when (> (hash-table-count definition-prefixes) 0)
    (maphash (lambda (prefix files)
               (let ((old (radix-tree-lookup help-definition-prefixes prefix)))
                 (setq help-definition-prefixes
                       (radix-tree-insert help-definition-prefixes
                                          prefix (append old files)))))
             definition-prefixes)
    (clrhash definition-prefixes))
  help-definition-prefixes)

(defun help--loaded-p (file)
  "Try and figure out if FILE has already been loaded."
93 94 95
  ;; FIXME: this regexp business is not good enough: for file
  ;; `toto', it will say `toto' is loaded when in reality it was
  ;; just cedet/semantic/toto that has been loaded.
96 97 98 99 100
  (or (let ((feature (intern-soft file)))
        (and feature (featurep feature)))
      (let* ((re (load-history-regexp file))
             (done nil))
        (dolist (x load-history)
101
          (and (stringp (car x)) (string-match-p re (car x)) (setq done t)))
102 103 104 105 106 107 108 109 110 111
        done)))

(defun help--load-prefixes (prefixes)
  (pcase-dolist (`(,prefix . ,files) prefixes)
    (setq help-definition-prefixes
          (radix-tree-insert help-definition-prefixes prefix nil))
    (dolist (file files)
      ;; FIXME: Should we scan help-definition-prefixes to remove
      ;; other prefixes of the same file?
      (unless (help--loaded-p file)
112 113
        (with-demoted-errors "while loading: %S"
          (load file 'noerror 'nomessage))))))
114

115 116 117 118 119

(define-obsolete-variable-alias 'help-enable-completion-auto-load
  'help-enable-completion-autoload "27.1")

(defcustom help-enable-completion-autoload t
120 121 122 123 124 125 126 127 128
  "Whether completion for Help commands can perform autoloading.
If non-nil, whenever invoking completion for `describe-function'
or `describe-variable' load files that might contain definitions
with the current prefix.  The files are chosen according to
`definition-prefixes'."
  :type 'boolean
  :group 'help
  :version "26.3")

129
(defun help--symbol-completion-table (string pred action)
130
  (when help-enable-completion-autoload
131 132
    (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string)))
      (help--load-prefixes prefixes)))
133
  (let ((prefix-completions
134
         (and help-enable-completion-autoload
135
              (mapcar #'intern (all-completions string definition-prefixes)))))
136 137 138 139 140
    (complete-with-action action obarray string
                          (if pred (lambda (sym)
                                     (or (funcall pred sym)
                                         (memq sym prefix-completions)))))))

141
(defvar describe-function-orig-buffer nil
142
  "Buffer that was current when `describe-function' was invoked.
143
Functions on `help-fns-describe-function-functions' can use this
144 145
to get buffer-local values.")

146 147
;;;###autoload
(defun describe-function (function)
148 149
  "Display the full documentation of FUNCTION (a symbol).
When called from lisp, FUNCTION may also be a function object."
150
  (interactive
151 152 153 154 155 156
   (let* ((fn (function-called-at-point))
          (enable-recursive-minibuffers t)
          (val (completing-read
                (if fn
                    (format "Describe function (default %s): " fn)
                  "Describe function: ")
157 158 159
                #'help--symbol-completion-table
                (lambda (f) (or (fboundp f) (get f 'function-documentation)))
                t nil nil
160 161 162 163 164
                (and fn (symbol-name fn)))))
     (unless (equal val "")
       (setq fn (intern val)))
     (unless (and fn (symbolp fn))
       (user-error "You didn't specify a function symbol"))
165
     (unless (or (fboundp fn) (get fn 'function-documentation))
166 167
       (user-error "Symbol's function definition is void: %s" fn))
     (list fn)))
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187

  ;; We save describe-function-orig-buffer on the help xref stack, so
  ;; it is restored by the back/forward buttons.  'help-buffer'
  ;; expects (current-buffer) to be a help buffer when processing
  ;; those buttons, so we can't change the current buffer before
  ;; calling that.
  (let ((describe-function-orig-buffer
         (or describe-function-orig-buffer
             (current-buffer))))

    (help-setup-xref
     (list (lambda (function buffer)
             (let ((describe-function-orig-buffer
                    (if (buffer-live-p buffer) buffer)))
               (describe-function function)))
           function describe-function-orig-buffer)
     (called-interactively-p 'interactive))

    (save-excursion
      (with-help-window (help-buffer)
188 189 190
        (if (get function 'reader-construct)
            (princ function)
          (prin1 function))
191 192 193 194 195 196 197 198
        ;; Use " is " instead of a colon so that
        ;; it is easier to get out the function name using forward-sexp.
        (princ " is ")
        (describe-function-1 function)
        (with-current-buffer standard-output
          ;; Return the text we displayed.
          (buffer-string))))
    ))
199 200 201 202 203 204 205 206 207 208 209 210


;; Could be this, if we make symbol-file do the work below.
;; (defun help-C-file-name (subr-or-var kind)
;;   "Return the name of the C file where SUBR-OR-VAR is defined.
;; KIND should be `var' for a variable or `subr' for a subroutine."
;;   (symbol-file (if (symbolp subr-or-var) subr-or-var
;; 		 (subr-name subr-or-var))
;; 	       (if (eq kind 'var) 'defvar 'defun)))
;;;###autoload
(defun help-C-file-name (subr-or-var kind)
  "Return the name of the C file where SUBR-OR-VAR is defined.
211 212
KIND should be `var' for a variable or `subr' for a subroutine.
If we can't find the file name, nil is returned."
213 214 215
  (let ((docbuf (get-buffer-create " *DOC*"))
	(name (if (eq 'var kind)
		  (concat "V" (symbol-name subr-or-var))
216
		(concat "F" (subr-name (advice--cd*r subr-or-var))))))
217 218 219 220 221 222 223
    (with-current-buffer docbuf
      (goto-char (point-min))
      (if (eobp)
	  (insert-file-contents-literally
	   (expand-file-name internal-doc-file-name doc-directory)))
      (let ((file (catch 'loop
		    (while t
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
		      (let ((pnt (search-forward (concat "\^_" name "\n")
                                                 nil t)))
                        (if (not pnt)
                            (throw 'loop nil)
			  (re-search-backward "\^_S\\(.*\\)")
			  (let ((file (match-string 1)))
			    (if (member file build-files)
			        (throw 'loop file)
			      (goto-char pnt)))))))))
        (if (not file)
            nil
	  (if (string-match "^ns.*\\(\\.o\\|obj\\)\\'" file)
	      (setq file (replace-match ".m" t t file 1))
	    (if (string-match "\\.\\(o\\|obj\\)\\'" file)
	        (setq file (replace-match ".c" t t file))))
	  (if (string-match "\\.\\(c\\|m\\)\\'" file)
	      (concat "src/" file)
	    file))))))
242

243 244 245 246 247 248 249 250 251 252 253 254
(defcustom help-downcase-arguments nil
  "If non-nil, argument names in *Help* buffers are downcased."
  :type 'boolean
  :group 'help
  :version "23.2")

(defun help-highlight-arg (arg)
  "Highlight ARG as an argument name for a *Help* buffer.
Return ARG in face `help-argument-name'; ARG is also downcased
if the variable `help-downcase-arguments' is non-nil."
  (propertize (if help-downcase-arguments (downcase arg) arg)
	      'face 'help-argument-name))
255 256 257 258

(defun help-do-arg-highlight (doc args)
  (with-syntax-table (make-syntax-table emacs-lisp-mode-syntax-table)
    (modify-syntax-entry ?\- "w")
Stefan Monnier's avatar
Stefan Monnier committed
259
    (dolist (arg args)
260 261 262 263 264 265 266 267 268 269
      (setq doc (replace-regexp-in-string
                 ;; This is heuristic, but covers all common cases
                 ;; except ARG1-ARG2
                 (concat "\\<"                   ; beginning of word
                         "\\(?:[a-z-]*-\\)?"     ; for xxx-ARG
                         "\\("
                         (regexp-quote arg)
                         "\\)"
                         "\\(?:es\\|s\\|th\\)?"  ; for ARGth, ARGs
                         "\\(?:-[a-z0-9-]+\\)?"  ; for ARG-xxx, ARG-n
270
                         "\\(?:-[{([<`\"‘].*?\\)?"; for ARG-{x}, (x), <x>, [x], `x', ‘x’
271
                         "\\>")                  ; end of word
272
                 (help-highlight-arg arg)
Stefan Monnier's avatar
Stefan Monnier committed
273 274
                 doc t t 1)))
    doc))
275 276

(defun help-highlight-arguments (usage doc &rest args)
277
  (when (and usage (string-match "^(" usage))
278 279 280 281 282 283 284 285 286 287
    (with-temp-buffer
      (insert usage)
      (goto-char (point-min))
      (let ((case-fold-search nil)
            (next (not (or args (looking-at "\\["))))
            (opt nil))
        ;; Make a list of all arguments
        (skip-chars-forward "^ ")
        (while next
          (or opt (not (looking-at " &")) (setq opt t))
288
          (if (not (re-search-forward " \\([\\[(]*\\)\\([^] &).]+\\)" nil t))
289 290 291 292 293 294 295
              (setq next nil)
            (setq args (cons (match-string 2) args))
            (when (and opt (string= (match-string 1) "("))
              ;; A pesky CL-style optional argument with default value,
              ;; so let's skip over it
              (search-backward "(")
              (goto-char (scan-sexps (point) 1)))))
Paul Eggert's avatar
Paul Eggert committed
296
        ;; Highlight arguments in the USAGE string
297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
        (setq usage (help-do-arg-highlight (buffer-string) args))
        ;; Highlight arguments in the DOC string
        (setq doc (and doc (help-do-arg-highlight doc args))))))
  ;; Return value is like the one from help-split-fundoc, but highlighted
  (cons usage doc))

;; The following function was compiled from the former functions
;; `describe-simplify-lib-file-name' and `find-source-lisp-file' with
;; some excerpts from `describe-function-1' and `describe-variable'.
;; The only additional twists provided are (1) locate the defining file
;; for autoloaded functions, and (2) give preference to files in the
;; "install directory" (directories found via `load-path') rather than
;; to files in the "compile directory" (directories found by searching
;; the loaddefs.el file).  We autoload it because it's also used by
;; `describe-face' (instead of `describe-simplify-lib-file-name').

;;;###autoload
(defun find-lisp-object-file-name (object type)
  "Guess the file that defined the Lisp object OBJECT, of type TYPE.
OBJECT should be a symbol associated with a function, variable, or face;
  alternatively, it can be a function definition.
318 319
If TYPE is `defvar', search for a variable definition.
If TYPE is `defface', search for a face definition.
320
If TYPE is not a symbol, search for a function definition.
321 322 323 324 325 326

The return value is the absolute name of a readable file where OBJECT is
defined.  If several such files exist, preference is given to a file
found via `load-path'.  The return value can also be `C-source', which
means that OBJECT is a function or variable defined in C.  If no
suitable file is found, return nil."
327
  (let* ((autoloaded (autoloadp type))
328 329
	 (file-name (or (and autoloaded (nth 1 type))
			(symbol-file
330 331 332 333
                         ;; FIXME: Why do we have this weird "If TYPE is the
                         ;; value returned by `symbol-function' for a function
                         ;; symbol" exception?
			 object (or (if (symbolp type) type) 'defun)))))
334 335 336 337 338 339 340 341 342 343 344 345 346 347 348
    (cond
     (autoloaded
      ;; An autoloaded function: Locate the file since `symbol-function'
      ;; has only returned a bare string here.
      (setq file-name
	    (locate-file file-name load-path '(".el" ".elc") 'readable)))
     ((and (stringp file-name)
	   (string-match "[.]*loaddefs.el\\'" file-name))
      ;; An autoloaded variable or face.  Visit loaddefs.el in a buffer
      ;; and try to extract the defining file.  The following form is
      ;; from `describe-function-1' and `describe-variable'.
      (let ((location
	     (condition-case nil
		 (find-function-search-for-symbol object nil file-name)
	       (error nil))))
349
	(when (cdr location)
350 351 352 353 354 355
	  (with-current-buffer (car location)
	    (goto-char (cdr location))
	    (when (re-search-backward
		   "^;;; Generated autoloads from \\(.*\\)" nil t)
	      (setq file-name
		    (locate-file
356 357 358
		     (file-name-sans-extension
		      (match-string-no-properties 1))
		     load-path '(".el" ".elc") 'readable))))))))
359 360 361 362 363 364 365 366

    (cond
     ((and (not file-name) (subrp type))
      ;; A built-in function.  The form is from `describe-function-1'.
      (if (get-buffer " *DOC*")
	  (help-C-file-name type 'subr)
	'C-source))
     ((and (not file-name) (symbolp object)
367
           (eq type 'defvar)
368 369 370 371 372 373 374 375
	   (integerp (get object 'variable-documentation)))
      ;; A variable defined in C.  The form is from `describe-variable'.
      (if (get-buffer " *DOC*")
	  (help-C-file-name object 'var)
	'C-source))
     ((not (stringp file-name))
      ;; If we don't have a file-name string by now, we lost.
      nil)
376
     ;; Now, `file-name' should have become an absolute file name.
377 378 379
     ;; For files loaded from ~/.foo.elc, try ~/.foo.
     ;; This applies to config files like ~/.emacs,
     ;; which people sometimes compile.
380
     ((let (fn)
381 382 383 384 385
	(and (string-match "\\`\\..*\\.elc\\'"
			   (file-name-nondirectory file-name))
	     (string-equal (file-name-directory file-name)
			   (file-name-as-directory (expand-file-name "~")))
	     (file-readable-p (setq fn (file-name-sans-extension file-name)))
386 387 388
	     fn)))
     ;; When the Elisp source file can be found in the install
     ;; directory, return the name of that file.
389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406
     ((let ((lib-name
	     (if (string-match "[.]elc\\'" file-name)
		 (substring-no-properties file-name 0 -1)
	       file-name)))
	(or (and (file-readable-p lib-name) lib-name)
	    ;; The library might be compressed.
	    (and (file-readable-p (concat lib-name ".gz")) lib-name))))
     ((let* ((lib-name (file-name-nondirectory file-name))
	     ;; The next form is from `describe-simplify-lib-file-name'.
	     (file-name
	      ;; Try converting the absolute file name to a library
	      ;; name, convert that back to a file name and see if we
	      ;; get the original one.  If so, they are equivalent.
	      (if (equal file-name (locate-file lib-name load-path '("")))
		  (if (string-match "[.]elc\\'" lib-name)
		      (substring-no-properties lib-name 0 -1)
		    lib-name)
		file-name))
407
	     (src-file (locate-library file-name t nil 'readable)))
408 409
	(and src-file (file-readable-p src-file) src-file))))))

410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426
(defun help-fns--key-bindings (function)
  (when (commandp function)
    (let ((pt2 (with-current-buffer standard-output (point)))
          (remapped (command-remapping function)))
      (unless (memq remapped '(ignore undefined))
        (let ((keys (where-is-internal
                     (or remapped function) overriding-local-map nil nil))
              non-modified-keys)
          (if (and (eq function 'self-insert-command)
                   (vectorp (car-safe keys))
                   (consp (aref (car keys) 0)))
              (princ "It is bound to many ordinary text characters.\n")
            ;; Which non-control non-meta keys run this command?
            (dolist (key keys)
              (if (member (event-modifiers (aref key 0)) '(nil (shift)))
                  (push key non-modified-keys)))
            (when remapped
427 428
              (princ "Its keys are remapped to ")
              (princ (if (symbolp remapped)
429
                         (format-message "`%s'" remapped)
430 431
		       "an anonymous command"))
              (princ ".\n"))
432 433 434 435 436 437 438 439

            (when keys
              (princ (if remapped
                         "Without this remapping, it would be bound to "
                       "It is bound to "))
              ;; If lots of ordinary text characters run this command,
              ;; don't mention them one by one.
              (if (< (length non-modified-keys) 10)
440
                  (princ (mapconcat #'key-description keys ", "))
441 442 443 444
                (dolist (key non-modified-keys)
                  (setq keys (delq key keys)))
                (if keys
                    (progn
445
                      (princ (mapconcat #'key-description keys ", "))
446 447 448 449 450 451 452 453
                      (princ ", and many ordinary text characters"))
                  (princ "many ordinary text characters"))))
            (when (or remapped keys non-modified-keys)
              (princ ".")
              (terpri)))))

      (with-current-buffer standard-output
        (fill-region-as-paragraph pt2 (point))
454
        (unless (looking-back "\n\n" (- (point) 2))
455 456
          (terpri))))))

457
(defun help-fns--compiler-macro (function)
458
  (let ((handler (function-get function 'compiler-macro)))
459
    (when handler
460
      (insert "  This function has a compiler macro")
461 462
      (if (symbolp handler)
          (progn
463
            (insert (format-message " `%s'" handler))
464
            (save-excursion
465
              (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
466
                                  nil t)
467 468 469 470
              (help-xref-button 1 'help-function handler)))
        ;; FIXME: Obsolete since 24.4.
        (let ((lib (get function 'compiler-macro-file)))
          (when (stringp lib)
471
            (insert (format-message " in `%s'" lib))
472
            (save-excursion
473
              (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
474
                                  nil t)
475
              (help-xref-button 1 'help-function-cmacro function lib)))))
476 477
      (insert ".\n"))))

478
(defun help-fns--signature (function doc real-def real-function buffer)
479 480 481
  "Insert usage at point and return docstring.  With highlighting."
  (if (keymapp function)
      doc                       ; If definition is a keymap, skip arglist note.
482 483 484 485 486 487 488 489
    (let* ((advertised (gethash real-def advertised-signature-table t))
           (arglist (if (listp advertised)
                        advertised (help-function-arglist real-def)))
           (usage (help-split-fundoc doc function)))
      (if usage (setq doc (cdr usage)))
      (let* ((use (cond
                   ((and usage (not (listp advertised))) (car usage))
                   ((listp arglist)
490
                    (help--make-usage-docstring function arglist))
491 492 493 494 495 496 497 498 499 500 501 502 503
                   ((stringp arglist) arglist)
                   ;; Maybe the arglist is in the docstring of a symbol
                   ;; this one is aliased to.
                   ((let ((fun real-function))
                      (while (and (symbolp fun)
                                  (setq fun (symbol-function fun))
                                  (not (setq usage (help-split-fundoc
                                                    (documentation fun)
                                                    function)))))
                      usage)
                    (car usage))
                   ((or (stringp real-def)
                        (vectorp real-def))
504 505 506
                    (format "\nMacro: %s"
                            (help--docstring-quote
                             (format-kbd-macro real-def))))
507
                   (t "[Missing arglist.  Please make a bug report.]")))
508 509 510 511
             ;; Insert "`X", not "(\` X)", when documenting `X.
             (use1 (replace-regexp-in-string
                    "\\`(\\\\=\\\\\\\\=` \\([^\n ]*\\))\\'"
                    "\\\\=`\\1" use t))
512 513 514 515 516 517 518
             (high (if buffer
                       (let (subst-use1 subst-doc)
                         (with-current-buffer buffer
                           (setq subst-use1 (substitute-command-keys use1))
                           (setq subst-doc (substitute-command-keys doc)))
                         (help-highlight-arguments subst-use1 subst-doc))
                     (cons use1 doc))))
519 520 521
        (let ((fill-begin (point))
              (high-usage (car high))
              (high-doc (cdr high)))
522 523
          (unless (and (symbolp function)
                       (get function 'reader-construct))
524
            (insert high-usage "\n"))
525 526
          (fill-region fill-begin (point))
          high-doc)))))
527 528 529 530 531 532 533

(defun help-fns--parent-mode (function)
  ;; If this is a derived mode, link to the parent.
  (let ((parent-mode (and (symbolp function)
                          (get function
                               'derived-mode-parent))))
    (when parent-mode
534
      (insert (substitute-command-keys "  Parent mode: `"))
535 536 537 538 539
      (let ((beg (point)))
        (insert (format "%s" parent-mode))
        (make-text-button beg (point)
                          'type 'help-function
                          'help-args (list parent-mode)))
540
      (insert (substitute-command-keys "'.\n")))))
541 542

(defun help-fns--obsolete (function)
543 544 545
  ;; Ignore lambda constructs, keyboard macros, etc.
  (let* ((obsolete (and (symbolp function)
			(get function 'byte-obsolete-info)))
546 547
         (use (car obsolete)))
    (when obsolete
548
      (insert "  This "
549
	      (if (eq (car-safe (symbol-function function)) 'macro)
550 551 552
		  "macro"
		"function")
	      " is obsolete")
553 554
      (when (nth 2 obsolete)
        (insert (format " since %s" (nth 2 obsolete))))
555 556
      (insert (cond ((stringp use) (concat ";\n  " use))
                    (use (format-message ";\n  use `%s' instead." use))
557 558
                    (t "."))
              "\n"))))
559

560 561 562
(add-hook 'help-fns-describe-function-functions
          #'help-fns--globalized-minor-mode)
(defun help-fns--globalized-minor-mode (function)
563 564
  (when (and (symbolp function)
             (get function 'globalized-minor-mode))
565 566 567
    (help-fns--customize-variable function " the global mode variable.")
    (terpri)))

568 569 570 571 572 573 574 575 576
;; We could use `symbol-file' but this is a wee bit more efficient.
(defun help-fns--autoloaded-p (function file)
  "Return non-nil if FUNCTION has previously been autoloaded.
FILE is the file where FUNCTION was probably defined."
  (let* ((file (file-name-sans-extension (file-truename file)))
	 (load-hist load-history)
	 (target (cons t function))
	 found)
    (while (and load-hist (not found))
577
      (and (stringp (caar load-hist))
578 579 580 581 582
	   (equal (file-name-sans-extension (caar load-hist)) file)
	   (setq found (member target (cdar load-hist))))
      (setq load-hist (cdr load-hist)))
    found))

583 584 585 586 587 588 589 590 591 592 593
(defun help-fns--interactive-only (function)
  "Insert some help blurb if FUNCTION should only be used interactively."
  ;; Ignore lambda constructs, keyboard macros, etc.
  (and (symbolp function)
       (not (eq (car-safe (symbol-function function)) 'macro))
       (let* ((interactive-only
               (or (get function 'interactive-only)
                   (if (boundp 'byte-compile-interactive-only-functions)
                       (memq function
                             byte-compile-interactive-only-functions)))))
         (when interactive-only
594
           (insert "  This function is for interactive use only"
595 596
                   ;; Cf byte-compile-form.
                   (cond ((stringp interactive-only)
597
                          (format ";\n  in Lisp code %s" interactive-only))
598 599
                         ((and (symbolp 'interactive-only)
                               (not (eq interactive-only t)))
600
                          (format-message ";\n  in Lisp code use `%s' instead."
601
                                          interactive-only))
602 603 604
                         (t "."))
                   "\n")))))

605 606 607 608 609 610 611 612
(add-hook 'help-fns-describe-function-functions #'help-fns--side-effects)
(defun help-fns--side-effects (function)
  (when (and (symbolp function)
             (or (function-get function 'pure)
                 (function-get function 'side-effect-free)))
    (insert "  This function does not change global state, "
            "including the match data.\n")))

613 614 615 616 617 618
(add-hook 'help-fns-describe-function-functions #'help-fns--disabled)
(defun help-fns--disabled (function)
  (when (and (symbolp function)
             (function-get function 'disabled))
    (insert "  This function is disabled.\n")))

619
(defun help-fns--first-release (symbol)
620
  "Return the likely first release that defined SYMBOL, or nil."
621 622 623 624 625 626
  ;; Code below relies on the etc/NEWS* files.
  ;; FIXME: Maybe we should also use the */ChangeLog* files when available.
  ;; FIXME: Maybe we should also look for announcements of the addition
  ;; of the *packages* in which the function is defined.
  (let* ((name (symbol-name symbol))
         (re (concat "\\_<" (regexp-quote name) "\\_>"))
627
         (news (directory-files data-directory t "\\`NEWS\\.[1-9]"))
628
         (place nil)
629 630 631 632 633 634 635 636
         (first nil))
    (with-temp-buffer
      (dolist (f news)
        (erase-buffer)
        (insert-file-contents f)
        (goto-char (point-min))
        (search-forward "\n*")
        (while (re-search-forward re nil t)
637 638 639 640 641
          (let ((pos (match-beginning 0)))
            (save-excursion
              ;; Almost all entries are of the form "* ... in Emacs NN.MM."
              ;; but there are also a few in the form "* Emacs NN.MM is a bug
              ;; fix release ...".
642
              (if (not (re-search-backward "^\\*.* Emacs \\([0-9.]+[0-9]\\)"
643 644 645 646 647 648 649
                                           nil t))
                  (message "Ref found in non-versioned section in %S"
                           (file-name-nondirectory f))
                (let ((version (match-string 1)))
                  (when (or (null first) (version< version first))
                    (setq place (list f pos))
                    (setq first version)))))))))
650
    (when first
651
      (make-text-button first nil 'type 'help-news 'help-args place))))
652 653 654 655 656 657 658 659

(add-hook 'help-fns-describe-function-functions
          #'help-fns--mention-first-release)
(add-hook 'help-fns-describe-variable-functions
          #'help-fns--mention-first-release)
(defun help-fns--mention-first-release (object)
  (let ((first (if (symbolp object) (help-fns--first-release object))))
    (when first
660 661 662
      (with-current-buffer standard-output
        (insert (format "  Probably introduced at or before Emacs version %s.\n"
                        first))))))
663

664 665 666 667 668 669 670 671 672 673 674 675
(defun help-fns-short-filename (filename)
  (let* ((abbrev (abbreviate-file-name filename))
         (short abbrev))
    (dolist (dir load-path)
      (let ((rel (file-relative-name filename dir)))
        (if (< (length rel) (length short))
            (setq short rel)))
      (let ((rel (file-relative-name abbrev dir)))
        (if (< (length rel) (length short))
            (setq short rel))))
    short))

Paul Eggert's avatar
Paul Eggert committed
676
(defun help-fns--analyze-function (function)
677 678
  ;; FIXME: Document/explain the differences between FUNCTION,
  ;; REAL-FUNCTION, DEF, and REAL-DEF.
679 680
  "Return information about FUNCTION.
Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
681 682
  (let* ((advised (and (symbolp function)
		       (advice--p (advice--symbol-function function))))
683 684 685 686
	 ;; If the function is advised, use the symbol that has the
	 ;; real definition, if that symbol is already set up.
	 (real-function
	  (or (and advised
687
                   (advice--cd*r (advice--symbol-function function)))
688
	      function))
689
	 ;; Get the real definition, if any.
690
	 (def (if (symbolp real-function)
691 692 693 694
                  (cond ((symbol-function real-function))
                        ((get real-function 'function-documentation)
                         nil)
                        (t (signal 'void-function (list real-function))))
695
		real-function))
696 697 698 699 700 701 702 703
	 (aliased (and def
                       (or (symbolp def)
                           ;; Advised & aliased function.
                           (and advised (symbolp real-function)
                                (not (eq 'autoload (car-safe def))))
                           (and (subrp def)
                                (not (string= (subr-name def)
                                              (symbol-name function)))))))
704
	 (real-def (cond
705 706 707 708 709 710
                    ((and aliased (not (subrp def)))
                     (let ((f real-function))
                       (while (and (fboundp f)
                                   (symbolp (symbol-function f)))
                         (setq f (symbol-function f)))
                       f))
711
		    ((subrp def) (intern (subr-name def)))
712 713 714 715 716 717
                    (t def))))
    (list real-function def aliased real-def)))

(defun help-fns-function-description-header (function)
  "Print a line describing FUNCTION to `standard-output'."
  (pcase-let* ((`(,_real-function ,def ,aliased ,real-def)
Paul Eggert's avatar
Paul Eggert committed
718
                (help-fns--analyze-function function))
719 720 721 722 723 724 725
               (file-name (find-lisp-object-file-name function (if aliased 'defun
                                                                 def)))
               (beg (if (and (or (byte-code-function-p def)
                                 (keymapp def)
                                 (memq (car-safe def) '(macro lambda closure)))
                             (stringp file-name)
                             (help-fns--autoloaded-p function file-name))
726 727 728
                        (concat
                         "an autoloaded " (if (commandp def)
                                              "interactive "))
729
                      (if (commandp def) "an interactive " "a "))))
730 731 732 733

    ;; Print what kind of function-like object FUNCTION is.
    (princ (cond ((or (stringp def) (vectorp def))
		  "a keyboard macro")
734 735
		 ((and (symbolp function)
                       (get function 'reader-construct))
736
                  "a reader construct")
737 738
		 ;; Aliases are Lisp functions, so we need to check
		 ;; aliases before functions.
739
		 (aliased
740
		  (format-message "an alias for `%s'" real-def))
741
		 ((subrp def)
742 743 744
		  (concat beg (if (eq 'unevalled (cdr (subr-arity def)))
		                  "special form"
                                "built-in function")))
745
		 ((autoloadp def)
746 747 748 749 750 751
		  (format "an autoloaded %s"
                          (cond
			   ((commandp def) "interactive Lisp function")
			   ((eq (nth 4 def) 'keymap) "keymap")
			   ((nth 4 def) "Lisp macro")
                           (t "Lisp function"))))
752 753 754 755 756 757 758 759
		 ((or (eq (car-safe def) 'macro)
		      ;; For advised macros, def is a lambda
		      ;; expression or a byte-code-function-p, so we
		      ;; need to check macros before functions.
		      (macrop function))
		  (concat beg "Lisp macro"))
		 ((byte-code-function-p def)
		  (concat beg "compiled Lisp function"))
760 761
                 ((module-function-p def)
                  (concat beg "module function"))
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777
		 ((eq (car-safe def) 'lambda)
		  (concat beg "Lisp function"))
		 ((eq (car-safe def) 'closure)
		  (concat beg "Lisp closure"))
		 ((keymapp def)
		  (let ((is-full nil)
			(elts (cdr-safe def)))
		    (while elts
		      (if (char-table-p (car-safe elts))
			  (setq is-full t
				elts nil))
		      (setq elts (cdr-safe elts)))
		    (concat beg (if is-full "keymap" "sparse keymap"))))
		 (t "")))

    (if (and aliased (not (fboundp real-def)))
778 779 780 781
	(princ ",\nwhich is not defined.  Please make a bug report.")
      (with-current-buffer standard-output
	(save-excursion
	  (save-match-data
782
	    (when (re-search-backward (substitute-command-keys
783
                                       "alias for `\\([^`']+\\)'")
784
                                      nil t)
785
	      (help-xref-button 1 'help-function real-def)))))
786 787 788 789

      (when file-name
	;; We used to add .el to the file name,
	;; but that's completely wrong when the user used load-file.
790
	(princ (format-message " in `%s'"
791 792 793
                               (if (eq file-name 'C-source)
                                   "C source code"
                                 (help-fns-short-filename file-name))))
794 795 796
	;; Make a hyperlink to the library.
	(with-current-buffer standard-output
	  (save-excursion
797
	    (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
798
                                nil t)
799
	    (help-xref-button 1 'help-function-def function file-name))))
800 801
      (princ "."))))

802 803 804 805
(defun help-fns--ensure-empty-line ()
  (unless (eolp) (insert "\n"))
  (unless (eq ?\n (char-before (1- (point)))) (insert "\n")))

806 807 808 809 810 811 812 813 814
;;;###autoload
(defun describe-function-1 (function)
  (let ((pt1 (with-current-buffer (help-buffer) (point))))
    (help-fns-function-description-header function)
    (with-current-buffer (help-buffer)
      (fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point))
                                (point))))
  (terpri)(terpri)

815
  (pcase-let* ((`(,real-function ,def ,_aliased ,real-def)
Paul Eggert's avatar
Paul Eggert committed
816
                (help-fns--analyze-function function))
817 818 819 820 821
               (doc-raw (condition-case nil
                            ;; FIXME: Maybe `documentation' should return nil
                            ;; for invalid functions i.s.o. signaling an error.
                            (documentation function t)
                          ;; E.g. an alias for a not yet defined function.
822
                          ((invalid-function void-function) nil)))
823
               (key-bindings-buffer (current-buffer)))
824 825 826 827

    ;; If the function is autoloaded, and its docstring has
    ;; key substitution constructs, load the library.
    (and (autoloadp real-def) doc-raw
828
         help-enable-autoload
829 830 831 832 833
         (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw)
         (autoload-do-load real-def))

    (help-fns--key-bindings function)
    (with-current-buffer standard-output
834 835 836 837 838 839 840 841
      (let ((doc (condition-case nil
                     ;; FIXME: Maybe `help-fns--signature' should return `doc'
                     ;; for invalid functions i.s.o. signaling an error.
                     (help-fns--signature
                      function doc-raw
                      (if (subrp def) (indirect-function real-def) real-def)
                      real-function key-bindings-buffer)
                   ;; E.g. an alias for a not yet defined function.
842
                   ((invalid-function void-function) doc-raw))))
843
        (help-fns--ensure-empty-line)
844
        (run-hook-with-args 'help-fns-describe-function-functions function)
845 846
        (help-fns--ensure-empty-line)
        (insert (or doc "Not documented.")))
847 848 849 850 851
      ;; Avoid asking the user annoying questions if she decides
      ;; to save the help buffer, when her locale's codeset
      ;; isn't UTF-8.
      (unless (memq text-quoting-style '(straight grave))
        (set-buffer-file-coding-system 'utf-8)))))
852

853
;; Add defaults to `help-fns-describe-function-functions'.
854
(add-hook 'help-fns-describe-function-functions #'help-fns--obsolete)
855
(add-hook 'help-fns-describe-function-functions #'help-fns--interactive-only)
856 857
(add-hook 'help-fns-describe-function-functions #'help-fns--parent-mode)
(add-hook 'help-fns-describe-function-functions #'help-fns--compiler-macro)
858

859 860 861 862 863 864 865 866 867 868 869

;; Variables

;;;###autoload
(defun variable-at-point (&optional any-symbol)
  "Return the bound variable symbol found at or before point.
Return 0 if there is no such symbol.
If ANY-SYMBOL is non-nil, don't insist the symbol be bound."
  (with-syntax-table emacs-lisp-mode-syntax-table
    (or (condition-case ()
	    (save-excursion
870
	      (skip-chars-forward "'")
871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888
	      (or (not (zerop (skip-syntax-backward "_w")))
		  (eq (char-syntax (following-char)) ?w)
		  (eq (char-syntax (following-char)) ?_)
		  (forward-sexp -1))
	      (skip-chars-forward "'")
	      (let ((obj (read (current-buffer))))
		(and (symbolp obj) (boundp obj) obj)))
          (error nil))
        (let* ((str (find-tag-default))
               (sym (if str (intern-soft str))))
          (if (and sym (or any-symbol (boundp sym)))
              sym
            (save-match-data
              (when (and str (string-match "\\`\\W*\\(.*?\\)\\W*\\'" str))
                (setq sym (intern-soft (match-string 1 str)))
                (and (or any-symbol (boundp sym)) sym)))))
        0)))

889
(defun describe-variable-custom-version-info (variable &optional type)
890 891
  (let ((custom-version (get variable 'custom-version))
	(cpv (get variable 'custom-package-version))
892
        (type (or type "variable"))
893 894 895
	(output nil))
    (if custom-version
	(setq output
896
	      (format "  This %s was introduced, or its default value was changed, in\n  version %s of Emacs.\n"
897
                      type custom-version))
898 899 900 901 902 903 904 905 906
      (when cpv
	(let* ((package (car-safe cpv))
	       (version (if (listp (cdr-safe cpv))
			    (car (cdr-safe cpv))
			  (cdr-safe cpv)))
	       (pkg-versions (assq package customize-package-emacs-version-alist))
	       (emacsv (cdr (assoc version pkg-versions))))
	  (if (and package version)
	      (setq output
907
		    (format (concat "  This %s was introduced, or its default value was changed, in\n  version %s of the %s package"
908 909 910
				    (if emacsv
					(format " that is part of Emacs %s" emacsv))
				    ".\n")
911
			    type version package))))))
912 913 914 915 916 917 918 919 920 921 922 923
    output))

;;;###autoload
(defun describe-variable (variable &optional buffer frame)
  "Display the full documentation of VARIABLE (a symbol).
Returns the documentation as a string, also.
If VARIABLE has a buffer-local value in BUFFER or FRAME
\(default to the current buffer and current frame),
it is displayed along with the global value."
  (interactive
   (let ((v (variable-at-point))
	 (enable-recursive-minibuffers t)
924
         (orig-buffer (current-buffer))
925
	 val)
926 927 928 929 930
     (setq val (completing-read
                (if (symbolp v)
                    (format
                     "Describe variable (default %s): " v)
                  "Describe variable: ")
931
                #'help--symbol-completion-table
932 933 934 935 936 937 938 939 940
                (lambda (vv)
                  ;; In case the variable only exists in the buffer
                  ;; the command we switch back to that buffer before
                  ;; we examine the variable.
                  (with-current-buffer orig-buffer
                    (or (get vv 'variable-documentation)
                        (and (boundp vv) (not (keywordp vv))))))
                t nil nil
                (if (symbolp v) (symbol-name v))))
941 942 943 944 945 946
     (list (if (equal val "")
	       v (intern val)))))
  (let (file-name)
    (unless (buffer-live-p buffer) (setq buffer (current-buffer)))
    (unless (frame-live-p frame) (setq frame (selected-frame)))
    (if (not (symbolp variable))
947
	(user-error "You didn't specify a variable")
948 949 950 951 952 953 954 955 956 957 958
      (save-excursion
	(let ((valvoid (not (with-current-buffer buffer (boundp variable))))
	      val val-start-pos locus)
	  ;; Extract the value before setting up the output buffer,
	  ;; in case `buffer' *is* the output buffer.
	  (unless valvoid
	    (with-selected-frame frame
	      (with-current-buffer buffer
		(setq val (symbol-value variable)
		      locus (variable-binding-locus variable)))))
	  (help-setup-xref (list #'describe-variable variable buffer)
959
			   (called-interactively-p 'interactive))
960 961 962 963 964
	  (with-help-window (help-buffer)
	    (with-current-buffer buffer
	      (prin1 variable)
	      (setq file-name (find-lisp-object-file-name variable 'defvar))

965 966 967 968 969 970
	      (princ (if file-name
		         (progn
		           (princ (format-message
                                   " is a variable defined in `%s'.\n"
                                   (if (eq file-name 'C-source)
                                       "C source code"
971
                                     (help-fns-short-filename file-name))))
972 973 974 975 976 977 978 979 980 981 982 983 984
		           (with-current-buffer standard-output
		             (save-excursion
			       (re-search-backward (substitute-command-keys
                                                    "`\\([^`']+\\)'")
                                                   nil t)
			       (help-xref-button 1 'help-variable-def
					         variable file-name)))
		           (if valvoid
			       "It is void as a variable."
                             "Its "))
                       (if valvoid
		           " is void as a variable."
                         (substitute-command-keys "'s ")))))
985
	    (unless valvoid
986 987
	      (with-current-buffer standard-output
		(setq val-start-pos (point))
988 989
		(princ "value is")
		(let ((line-beg (line-beginning-position))
990
		      (print-rep
991
		       (let ((rep
992
			      (let ((print-quoted t)
993
                                    (print-circle t))
994
				(cl-prin1-to-string val))))
995 996 997
			 (if (and (symbolp val) (not (booleanp val)))
			     (format-message "`%s'" rep)
			   rep))))
998
		  (if (< (+ (length print-rep) (point) (- line-beg)) 68)
999
		      (insert " " print-rep)
1000
		    (terpri)
1001 1002
                    (let ((buf (current-buffer)))
                      (with-temp-buffer
1003 1004
                        (lisp-mode-variables nil)
                        (set-syntax-table emacs-lisp-mode-syntax-table)
1005 1006 1007 1008 1009
                        (insert print-rep)
                        (pp-buffer)
                        (let ((pp-buffer (current-buffer)))
                          (with-current-buffer buf
                            (insert-buffer-substring pp-buffer)))))
1010
                    ;; Remove trailing newline.
1011
                    (and (= (char-before) ?\n) (delete-char -1)))
1012 1013 1014
		  (let* ((sv (get variable 'standard-value))
			 (origval (and (consp sv)
				       (condition-case nil
1015
					   (eval (car sv) t)
1016 1017
					 (error :help-eval-error))))
                         from)
1018 1019 1020 1021 1022
		    (when (and (consp sv)
                               (not (equal origval val))
                               (not (equal origval :help-eval-error)))
		      (princ "\nOriginal value was \n")
		      (setq from (point))
1023 1024 1025 1026 1027
		      (if (and (symbolp origval) (not (booleanp origval)))
			  (let* ((rep (cl-prin1-to-string origval))
				 (print-rep (format-message "`%s'" rep)))
			    (insert print-rep))
			(cl-prin1 origval))
1028 1029 1030
                      (save-restriction
                        (narrow-to-region from (point))
                        (save-excursion (pp-buffer)))
1031 1032
		      (if (< (point) (+ from 20))
			  (delete-region (1- from) from)))))))
1033 1034
	    (terpri)
	    (when locus
1035 1036
	      (cond
               ((bufferp locus)
1037
                (princ (format "Local in buffer %s; "
1038
                               (buffer-name buffer))))
1039 1040 1041 1042
               ((terminal-live-p locus)
                (princ (format "It is a terminal-local variable; ")))
               (t
                (princ (format "It is local to %S" locus))))
1043 1044
	      (if (not (default-boundp variable))
		  (princ "globally void")
1045
		(let ((global-val (default-value variable)))
1046 1047
		  (with-current-buffer standard-output
		    (princ "global value is ")
1048 1049 1050 1051 1052 1053 1054 1055
		    (if (eq val global-val)
			(princ "the same.")
		      (terpri)
		      ;; Fixme: pp can take an age if you happen to
		      ;; ask for a very large expression.  We should
		      ;; probably print it raw once and check it's a
		      ;; sensible size before prettyprinting.  -- fx
		      (let ((from (point)))
1056 1057 1058 1059
                        (cl-prin1 global-val)
                        (save-restriction
                          (narrow-to-region from (point))
                          (save-excursion (pp-buffer)))
1060 1061 1062 1063
			;; See previous comment for this function.
			;; (help-xref-on-pp from (point))
			(if (< (point) (+ from 20))
			    (delete-region (1- from) from)))))))
1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093
              (terpri))

	    ;; If the value is large, move it to the end.
	    (with-current-buffer standard-output
	      (when (> (count-lines (point-min) (point-max)) 10)
		;; Note that setting the syntax table like below
		;; makes forward-sexp move over a `'s' at the end
		;; of a symbol.
		(set-syntax-table emacs-lisp-mode-syntax-table)
		(goto-char val-start-pos)
		;; The line below previously read as
		;; (delete-region (point) (progn (end-of-line) (point)))
		;; which suppressed display of the buffer local value for
		;; large values.
		(when (looking-at "value is") (replace-match ""))
		(save-excursion
		  (insert "\n\nValue:")
		  (set (make-local-variable 'help-button-cache)
		       (point-marker)))
		(insert "value is shown ")
		(insert-button "below"
			       'action help-button-cache
			       'follow-link t
			       'help-echo "mouse-2, RET: show value")
		(insert ".\n")))
            (terpri)

            (let* ((alias (condition-case nil
                              (indirect-variable variable)
                            (error variable)))
1094 1095 1096
                   (doc (or (documentation-property
                             variable 'variable-documentation)
                            (documentation-property
1097
                             alias 'variable-documentation))))
1098

1099 1100 1101 1102 1103 1104
              (with-current-buffer buffer
                (run-hook-with-args 'help-fns-describe-variable-functions
                                    variable))

              (with-current-buffer standard-output
                (help-fns--ensure-empty-line))
1105 1106 1107 1108
	      (princ "Documentation:\n")
	      (with-current-buffer standard-output
		(insert (or doc "Not documented as a variable."))))

1109
	    (with-current-buffer standard-output
1110 1111 1112
	      ;; Return the text we displayed.
	      (buffer-string))))))))

1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127
(add-hook 'help-fns-describe-variable-functions #'help-fns--customize-variable)
(defun help-fns--customize-variable (variable &optional text)
  ;; Make a link to customize if this variable can be customized.
  (when (custom-variable-p variable)
    (let ((customize-label "customize"))
      (princ (concat "  You can " customize-label (or text " this variable.")))
      (with-current-buffer standard-output
	(save-excursion
	  (re-search-backward
	   (concat "\\(" customize-label "\\)") nil t)
	  (help-xref-button 1 'help-customize-variable variable)))
      (terpri))
    ;; Note variable's version or package version.
    (let ((output (describe-variable-custom-version-info variable)))
      (when output
1128 1129
	;; (terpri)
	;; (terpri)
1130 1131
	(princ output)))))

1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236
(add-hook 'help-fns-describe-variable-functions #'help-fns--var-safe-local)
(defun help-fns--var-safe-local (variable)
  (let ((safe-var (get variable 'safe-local-variable)))
    (when safe-var
      (princ "  This variable is safe as a file local variable ")
      (princ "if its value\n  satisfies the predicate ")
      (princ (if (byte-code-function-p safe-var)
		 "which is a byte-compiled expression.\n"
	       (format-message "`%s'.\n" safe-var))))))

(add-hook 'help-fns-describe-variable-functions #'help-fns--var-risky)
(defun help-fns--var-risky (variable)
  ;; Can be both risky and safe, eg auto-fill-function.
  (when (risky-local-variable-p variable)
    (princ "  This variable may be risky if used as a \
file-local variable.\n")
    (when (assq variable safe-local-variable-values)
      (princ (substitute-command-keys
              "  However, you have added it to \
`safe-local-variable-values'.\n")))))

(add-hook 'help-fns-describe-variable-functions #'help-fns--var-ignored-local)
(defun help-fns--var-ignored-local (variable)
  (when (memq variable ignored-local-variables)
    (princ "  This variable is ignored as a file-local \
variable.\n")))

(add-hook 'help-fns-describe-variable-functions #'help-fns--var-file-local)
(defun help-fns--var-file-local (variable)
  (when (boundp variable)
    (let ((val (symbol-value variable)))
      (when (member (cons variable val)
                    file-local-variables-alist)
        (if (member (cons variable val)
                    dir-local-variables-alist)
	    (let ((file (and buffer-file-name
                             (not (file-remote-p buffer-file-name))
                             (dir-locals-find-file buffer-file-name)))
                  (is-directory nil))
	      (princ (substitute-command-keys
		      "  This variable's value is directory-local"))
              (when (consp file)       ; result from cache
                ;; If the cache element has an mtime, we
                ;; assume it came from a file.
                (if (nth 2 file)
                    ;; (car file) is a directory.
                    (setq file (dir-locals--all-files (car file)))
                  ;; Otherwise, assume it was set directly.
                  (setq file (car file)
                        is-directory t)))
              (if (null file)
                  (princ ".\n")
                (princ ", set ")
                (princ (substitute-command-keys
                        (cond
                         (is-directory "for the directory\n  `")
                         ;; Many files matched.
                         ((and (consp file) (cdr file))
                          (setq file (file-name-directory (car file)))
                          (format "by one of the\n  %s files in the directory\n  `"
                                  dir-locals-file))
                         (t (setq file (car file))
                            "by the file\n  `"))))
	        (with-current-buffer standard-output
	          (insert-text-button
	           file 'type 'help-dir-local-var-def
                   'help-args (list variable file)))
	        (princ (substitute-command-keys "'.\n"))))
          (princ (substitute-command-keys
	          "  This variable's value is file-local.\n")))))))

(add-hook 'help-fns-describe-variable-functions #'help-fns--var-watchpoints)
(defun help-fns--var-watchpoints (variable)
  (let ((watchpoints (get-variable-watchers variable)))
    (when watchpoints
      (princ "  Calls these functions when changed: ")
      ;; FIXME: Turn function names into hyperlinks.
      (princ watchpoints)
      (terpri))))

(add-hook 'help-fns-describe-variable-functions #'help-fns--var-obsolete)
(defun help-fns--var-obsolete (variable)
  (let* ((obsolete (get variable 'byte-obsolete-variable))
	 (use (car obsolete)))
    (when obsolete
      (princ "  This variable is obsolete")
      (if (nth 2 obsolete)
          (princ (format " since %s" (nth 2 obsolete))))
      (princ (cond ((stringp use) (concat ";\n  " use))
		   (use (format-message ";\n  use `%s' instead."
                                        (car obsolete)))
		   (t ".")))
      (terpri))))

(add-hook 'help-fns-describe-variable-functions #'help-fns--var-alias)
(defun help-fns--var-alias (variable)
  ;; Mention if it's an alias.
  (let ((alias (condition-case nil
                   (indirect-variable variable)
                 (error variable))))
    (unless (eq alias variable)
      (princ (format-message
              "  This variable is an alias for `%s'.\n"
              alias)))))

1237 1238 1239
(add-hook 'help-fns-describe-variable-functions #'help-fns--var-aliases)
(defun help-fns--var-aliases (variable)
  ;; Mention if it has any aliases.
1240
  (let (aliases alias)
1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260
    (mapatoms
     (lambda (sym)
       (when (and (boundp sym)
		  (setq alias (indirect-variable sym))
                  (eq alias variable)
		  (not (eq alias sym)))
	 (push sym aliases)))
     obarray)
    (when aliases
      (princ
       (if (= (length aliases) 1)
           (format-message
            "  This variable has an alias: `%s'.\n" (car aliases))
         (format-message
          "  This variable has the following aliases: %s.\n"
          (mapconcat
           (lambda (sym)
             (format "`%s'" sym))
           aliases ",\n    ")))))))

1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283
(add-hook 'help-fns-describe-variable-functions #'help-fns--var-bufferlocal)
(defun help-fns--var-bufferlocal (variable)
  (let ((permanent-local (get variable 'permanent-local))
        (locus (variable-binding-locus variable)))
    ;; Mention if it's a local variable.
    (cond
     ((and (local-variable-if-set-p variable)
	   (or (not (local-variable-p variable))
	       (with-temp-buffer
	         (local-variable-if-set-p variable))))
      (princ "  Automatically becomes ")
      (if permanent-local
	  (princ "permanently "))
      (princ "buffer-local when set.\n"))
     ((not permanent-local))
     ((bufferp locus)
      (princ
       (substitute-command-keys
        "  This variable's buffer-local value is permanent.\n")))
     (t
      (princ (substitute-command-keys
	      "  This variable's value is permanent \
if it is given a local binding.\n"))))))
1284

1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354

;; Faces.

;;;###autoload
(defun describe-face (face &optional frame)
  "Display the properties of face FACE on FRAME.
Interactively, FACE defaults to the faces of the character after point
and FRAME defaults to the selected frame.

If the optional argument FRAME is given, report on face FACE in that frame.
If FRAME is t, report on the defaults for face FACE (for new frames).
If FRAME is omitted or nil, use the selected frame."
  (interactive (list (read-face-name "Describe face"
                                     (or (face-at-point t) 'default)
                                     t)))
  (help-setup-xref (list #'describe-face face)
		   (called-interactively-p 'interactive))
  (unless face
    (setq face 'default))
  (if (not (listp face))
      (setq face (list face)))
  (with-help-window (help-buffer)
    (with-current-buffer standard-output
      (dolist (f face (buffer-string))
	(if (stringp f) (setq f (intern f)))
	;; We may get called for anonymous faces (i.e., faces
	;; expressed using prop-value plists).  Those can't be
	;; usefully customized, so ignore them.
	(when (symbolp f)
	  (insert "Face: " (symbol-name f))
	  (if (not (facep f))
	      (insert "   undefined face.\n")
	    (let ((customize-label "customize this face")
		  file-name)
	      (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
	      (princ (concat " (" customize-label ")\n"))
	      ;; FIXME not sure how much of this belongs here, and
	      ;; how much in `face-documentation'.  The latter is
	      ;; not used much, but needs to return nil for
	      ;; undocumented faces.
	      (let ((alias (get f 'face-alias))
		    (face f)
		    obsolete)
		(when alias
		  (setq face alias)
		  (insert
		   (format-message
                    "\n  %s is an alias for the face `%s'.\n%s"
                    f alias
                    (if (setq obsolete (get f 'obsolete-face))
                        (format-message
                         "  This face is obsolete%s; use `%s' instead.\n"
                         (if (stringp obsolete)
                             (format " since %s" obsolete)
                           "")
                         alias)
                      ""))))
		(insert "\nDocumentation:\n"
                        (substitute-command-keys
                         (or (face-documentation face)
                             "Not documented as a face."))
			"\n\n"))
	      (with-current-buffer standard-output
		(save-excursion
		  (re-search-backward
		   (concat "\\(" customize-label "\\)") nil t)
		  (help-xref-button 1 'help-customize-face f)))
	      (setq file-name (find-lisp-object-file-name f 'defface))
	      (when file-name
		(princ (substitute-command-keys "Defined in `"))
1355
		(princ (help-fns-short-filename file-name))
1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393
		(princ (substitute-command-keys "'"))
		;; Make a hyperlink to the library.
		(save-excursion
		  (re-search-backward
                   (substitute-command-keys "`\\([^`']+\\)'") nil t)
		  (help-xref-button 1 'help-face-def f file-name))
		(princ ".")
		(terpri)
		(terpri))))
	  (terpri)
          (run-hook-with-args 'help-fns-describe-face-functions f frame))))))

(add-hook 'help-fns-describe-face-functions
          #'help-fns--face-custom-version-info)
(defun help-fns--face-custom-version-info (face _frame)
  (when-let ((version-info (describe-variable-custom-version-info face 'face)))
    (insert version-info)
    (terpri)))

(add-hook 'help-fns-describe-face-functions #'help-fns--face-attributes)
(defun help-fns--face-attributes (face frame)
  (let* ((attrs '((:family . "Family")
		  (:foundry . "Foundry")
		  (:width . "Width")
		  (:height . "Height")
		  (:weight . "Weight")
		  (:slant . "Slant")
		  (:foreground . "Foreground")
		  (:distant-foreground . "DistantForeground")
		  (:background . "Background")
		  (:underline . "Underline")
		  (:overline . "Overline")
		  (:strike-through . "Strike-through")
		  (:box . "Box")
		  (:inverse-video . "Inverse")
		  (:stipple . "Stipple")
		  (:font . "Font")
		  (:fontset . "Fontset")
1394
                  (:extend . "Extend")
1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410
		  (:inherit . "Inherit")))
	 (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
					 attrs))))
    (dolist (a attrs)
      (let ((attr (face-attribute face (car a) frame)))
	(insert (make-string (- max-width (length (cdr a))) ?\s)
		(cdr a) ": " (format "%s" attr))
	(if (and (eq (car a) :inherit)
		 (not (eq attr 'unspecified)))
	    ;; Make a hyperlink to the parent face.
	    (save-excursion
	      (re-search-backward ": \\([^:]+\\)" nil t)
	      (help-xref-button 1 'help-face attr)))
	(insert "\n")))
    (terpri)))

1411 1412
(defvar help-xref-stack-item)

1413
;;;###autoload
1414 1415
(defun describe-symbol (symbol &optional buffer frame)
  "Display the full documentation of SYMBOL.
Eli Zaretskii's avatar
Eli Zaretskii committed
1416 1417 1418 1419
Will show the info of SYMBOL as a function, variable, and/or face.
Optional arguments BUFFER and FRAME specify for which buffer and
frame to show the information about SYMBOL; they default to the
current buffer and the selected frame, respectively."
1420
  (interactive
1421
   (let* ((v-or-f (symbol-at-point))
1422 1423
          (found (if v-or-f (cl-some (lambda (x) (funcall (nth 1 x) v-or-f))
                                     describe-symbol-backends)))
1424 1425 1426
          (v-or-f (if found v-or-f (function-called-at-point)))
          (found (or found v-or-f))
          (enable-recursive-minibuffers t)
1427
          (val (completing-read (if found
1428
				    (format
1429
                                     "Describe symbol (default %s): " v-or-f)
1430
				  "Describe symbol: ")
1431
				#'help--symbol-completion-table
1432
				(lambda (vv)
1433 1434
                                  (cl-some (lambda (x) (funcall (nth 1 x) vv))
                                           describe-symbol-backends))
1435
				t nil nil
1436
				(if found (symbol-name v-or-f)))))
1437
     (list (if (equal val "")
1438
	       (or v-or-f "") (intern val)))))
1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461
  (if (not (symbolp symbol))
      (user-error "You didn't specify a function or variable"))
  (unless (buffer-live-p buffer) (setq buffer (current-buffer)))
  (unless (frame-live-p frame) (setq frame (selected-frame)))
  (with-current-buffer (help-buffer)
    ;; Push the previous item on the stack before clobbering the output buffer.
    (help-setup-xref nil nil)
    (let* ((docs
            (nreverse
             (delq nil
                   (mapcar (pcase-lambda (`(,name ,testfn ,descfn))
                             (when (funcall testfn symbol)
                               ;; Don't record the current entry in the stack.
                               (setq help-xref-stack-item nil)
                               (cons name
                                     (funcall descfn symbol buffer frame))))
                           describe-symbol-backends))))
           (single (null