emacs/lisp/help-funs.el

;;; help-funs.el --- Complex help functions

;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001
;;   Free Software Foundation, Inc.

;; Maintainer: FSF
;; Keywords: help, internal

;; 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 2, 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
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; 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:

;;;###autoload
(defun help-with-tutorial (&optional arg)
  "Select the Emacs learn-by-doing tutorial.
If there is a tutorial version written in the language
of the selected language environment, that version is used.
If there's no tutorial in that language, `TUTORIAL' is selected.
With arg, you are asked to choose which language."
  (interactive "P")
  (let ((lang (if arg
		  (read-language-name 'tutorial "Language: " "English")
		(if (get-language-info current-language-environment 'tutorial)
		    current-language-environment
		  "English")))
	file filename)
    (setq filename (get-language-info lang 'tutorial))
    (setq file (expand-file-name (concat "~/" filename)))
    (delete-other-windows)
    (if (get-file-buffer file)
	(switch-to-buffer (get-file-buffer file))
      (switch-to-buffer (create-file-buffer file))
      (setq buffer-file-name file)
      (setq default-directory (expand-file-name "~/"))
      (setq buffer-auto-save-file-name nil)
      (insert-file-contents (expand-file-name filename data-directory))
      (goto-char (point-min))
      (search-forward "\n<<")
      (beginning-of-line)
      (delete-region (point) (progn (end-of-line) (point)))
      (let ((n (- (window-height (selected-window))
		  (count-lines (point-min) (point))
		  6)))
	(if (< n 12)
	    (newline n)
	  ;; Some people get confused by the large gap.
	  (newline (/ n 2))
	  (insert "[Middle of page left blank for didactic purposes.  "
		  "Text continues below]")
	  (newline (- n (/ n 2)))))
      (goto-char (point-min))
      (set-buffer-modified-p nil))))

;;;###autoload
(defun locate-library (library &optional nosuffix path interactive-call)
  "Show the precise file name of Emacs library LIBRARY.
This command searches the directories in `load-path' like `M-x load-library'
to find the file that `M-x load-library RET LIBRARY RET' would load.
Optional second arg NOSUFFIX non-nil means don't add suffixes `.elc' or `.el'
to the specified name LIBRARY.

If the optional third arg PATH is specified, that list of directories
is used instead of `load-path'.

When called from a program, the file name is normaly returned as a
string.  When run interactively, the argument INTERACTIVE-CALL is t,
and the file name is displayed in the echo area."
  (interactive (list (read-string "Locate library: ")
		     nil nil
		     t))
  (let (result)
    (catch 'answer
      (mapc
       (lambda (dir)
	 (mapc
	  (lambda (suf)
	    (let ((try (expand-file-name (concat library suf) dir)))
	      (and (file-readable-p try)
		   (null (file-directory-p try))
		   (progn
		     (setq result try)
		     (throw 'answer try)))))
	  (if nosuffix
	      '("")
	    '(".elc" ".el" "")
	    (let ((basic '(".elc" ".el" ""))
		  (compressed '(".Z" ".gz" "")))
	      ;; If autocompression mode is on,
	      ;; consider all combinations of library suffixes
	      ;; and compression suffixes.
	      (if (rassq 'jka-compr-handler file-name-handler-alist)
		  (apply 'nconc
			 (mapcar (lambda (compelt)
				   (mapcar (lambda (baselt)
					     (concat baselt compelt))
					   basic))
				 compressed))
		basic)))))
       (or path load-path)))
    (and interactive-call
	 (if result
	     (message "Library is file %s" result)
	   (message "No library %s in search path" library)))
    result))


;; Functions

;;;###autoload
(defun describe-function (function)
  "Display the full documentation of FUNCTION (a symbol)."
  (interactive
   (let ((fn (function-called-at-point))
	 (enable-recursive-minibuffers t)
	 val)
     (setq val (completing-read (if fn
				    (format "Describe function (default %s): " fn)
				  "Describe function: ")
				obarray 'fboundp t nil nil (symbol-name fn)))
     (list (if (equal val "")
	       fn (intern val)))))
  (if (null function)
      (message "You didn't specify a function")
    (with-output-to-temp-buffer "*Help*"
      (prin1 function)
      ;; 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 nil (interactive-p))
      (print-help-return-message)
	(save-excursion
	  (set-buffer standard-output)
	  ;; Return the text we displayed.
	(buffer-string)))))

(defun describe-function-1 (function parens interactive-p)
  (let* ((def (if (symbolp function)
		  (symbol-function function)
		function))
	 file-name string need-close
	 (beg (if (commandp def) "an interactive " "a ")))
    (setq string
	  (cond ((or (stringp def)
		     (vectorp def))
		 "a keyboard macro")
		((subrp def)
		 (if (eq 'unevalled (cdr (subr-arity def)))
		     (concat beg "special form")
		   (concat beg "built-in function")))
		((byte-code-function-p def)
		 (concat beg "compiled Lisp function"))
		((symbolp def)
		 (while (symbolp (symbol-function def))
		   (setq def (symbol-function def)))
		 (format "an alias for `%s'" def))
		((eq (car-safe def) 'lambda)
		 (concat beg "Lisp function"))
		((eq (car-safe def) 'macro)
		 "a Lisp macro")
		((eq (car-safe def) 'mocklisp)
		 "a mocklisp function")
		((eq (car-safe def) 'autoload)
		 (setq file-name (nth 1 def))
		 (format "%s autoloaded %s"
			 (if (commandp def) "an interactive" "an")
			 (if (eq (nth 4 def) 'keymap) "keymap"
			   (if (nth 4 def) "Lisp macro" "Lisp function"))
			 ))
                ;; perhaps use keymapp here instead
                ((eq (car-safe def) 'keymap)
                 (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)))
                   (if is-full
                       "a full keymap"
                     "a sparse keymap")))
		(t "")))
    (when (and parens (not (equal string "")))
      (setq need-close t)
      (princ "("))
    (princ string)
    (with-current-buffer "*Help*"
      (save-excursion
	(save-match-data
	  (if (re-search-backward "alias for `\\([^`']+\\)'" nil t)
	      (help-xref-button 1 'help-function def)))))
    (or file-name
	(setq file-name (symbol-file function)))
    (if file-name
	(progn
	  (princ " in `")
	  ;; We used to add .el to the file name,
	  ;; but that's completely wrong when the user used load-file.
	  (princ file-name)
	  (princ "'")
	  ;; Make a hyperlink to the library.
	  (with-current-buffer "*Help*"
	    (save-excursion
	      (re-search-backward "`\\([^`']+\\)'" nil t)
	      (help-xref-button 1 'help-function-def function file-name)))))
    (if need-close (princ ")"))
    (princ ".")
    (terpri)
    (when (commandp function)
      (let ((keys (where-is-internal
		   function overriding-local-map nil nil)))
	(when keys
	  (princ "It is bound to ")
	  ;; FIXME: This list can be very long (f.ex. for self-insert-command).
	  (princ (mapconcat 'key-description keys ", "))
	  (princ ".")
	  (terpri))))
    ;; Handle symbols aliased to other symbols.
    (setq def (indirect-function def))
    ;; If definition is a macro, find the function inside it.
    (if (eq (car-safe def) 'macro)
	(setq def (cdr def)))
    (let ((arglist (cond ((byte-code-function-p def)
			  (car (append def nil)))
			 ((eq (car-safe def) 'lambda)
			  (nth 1 def))
			 ((and (eq (car-safe def) 'autoload)
			       (not (eq (nth 4 def) 'keymap)))
			  (concat "[Arg list not available until "
				  "function definition is loaded.]"))
			 (t t))))
      (cond ((listp arglist)
	     (princ (cons (if (symbolp function) function "anonymous")
			  (mapcar (lambda (arg)
				    (if (memq arg '(&optional &rest))
					arg
				      (intern (upcase (symbol-name arg)))))
				  arglist)))
	     (terpri))
	    ((stringp arglist)
	     (princ arglist)
	     (terpri))))
    (let ((doc (documentation function)))
      (if doc
	  (progn (terpri)
		 (princ doc)
		 (if (subrp def)
		     (with-current-buffer standard-output
		       (beginning-of-line)
		       ;; Builtins get the calling sequence at the end of
		       ;; the doc string.  Move it to the same place as
		       ;; for other functions.

		       ;; In cases where `function' has been fset to a
		       ;; subr we can't search for function's name in
		       ;; the doc string.  Kluge round that using the
		       ;; printed representation.  The arg list then
		       ;; shows the wrong function name, but that
		       ;; might be a useful hint.
		       (let* ((rep (prin1-to-string def))
			      (name (progn
				      (string-match " \\([^ ]+\\)>$" rep)
				      (match-string 1 rep))))
			 (if (looking-at (format "(%s[ )]" (regexp-quote name)))
			     (let ((start (point-marker)))
			       (goto-char (point-min))
			       (forward-paragraph)
			       (insert-buffer-substring (current-buffer) start)
			       (insert ?\n)
			       (delete-region (1- start) (point-max)))
			   (goto-char (point-min))
			   (forward-paragraph)
			   (insert
			    "[Missing arglist.  Please make a bug report.]\n")))
		       (goto-char (point-max))))
		 (help-setup-xref (list #'describe-function function)
				  interactive-p))
	(princ "not documented")))))


;; Variables

;;;###autoload
(defun variable-at-point ()
  "Return the bound variable symbol found around point.
Return 0 if there is no such symbol."
  (condition-case ()
      (with-syntax-table emacs-lisp-mode-syntax-table
	(save-excursion
	  (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))))
	    (or (and (symbolp obj) (boundp obj) obj)
		0))))
    (error 0)))

;;;###autoload
(defun describe-variable (variable &optional buffer)
  "Display the full documentation of VARIABLE (a symbol).
Returns the documentation as a string, also.
If VARIABLE has a buffer-local value in BUFFER (default to the current buffer),
it is displayed along with the global value."
  (interactive
   (let ((v (variable-at-point))
	 (enable-recursive-minibuffers t)
	 val)
     (setq val (completing-read (if (symbolp v)
				    (format
				     "Describe variable (default %s): " v)
				  "Describe variable: ")
				obarray 'boundp t nil nil
				(if (symbolp v) (symbol-name v))))
     (list (if (equal val "")
	       v (intern val)))))
  (unless (bufferp buffer) (setq buffer (current-buffer)))
  (if (not (symbolp variable))
      (message "You did not specify a variable")
    (let (valvoid)
      (with-current-buffer buffer
	(with-output-to-temp-buffer "*Help*"
	  (prin1 variable)
	  (if (not (boundp variable))
	      (progn
		(princ " is void")
		(setq valvoid t))
	    (let ((val (symbol-value variable)))
	      (with-current-buffer standard-output
		(princ "'s value is ")
		(terpri)
		(let ((from (point)))
		  (pp val)
		  (help-xref-on-pp from (point))
		  (if (< (point) (+ from 20))
		      (save-excursion
			(goto-char from)
			(delete-char -1)))))))
	  (terpri)
	  (when (local-variable-p variable)
	    (princ (format "Local in buffer %s; " (buffer-name)))
	    (if (not (default-boundp variable))
		(princ "globally void")
	      (let ((val (default-value variable)))
		(with-current-buffer standard-output
		  (princ "global value is ")
		  (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)))
			(pp val)
			(help-xref-on-pp from (point))
			(if (< (point) (+ from 20))
			    (save-excursion
			      (goto-char from)
			      (delete-char -1)))))))
	    (terpri))
	  (terpri)
	  (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 (point-min))
	      (if valvoid
		  (forward-line 1)
		(forward-sexp 1)
		(delete-region (point) (progn (end-of-line) (point)))
		(insert " value is shown below.\n\n")
		(save-excursion
		  (insert "\n\nValue:"))))
	    ;; Add a note for variables that have been make-var-buffer-local.
	    (when (and (local-variable-if-set-p variable)
		       (or (not (local-variable-p variable))
			   (with-temp-buffer
			     (local-variable-if-set-p variable))))
	      (save-excursion
		(forward-line -1)
		(insert "Automatically becomes buffer-local when set in any fashion.\n"))))
	  (princ "Documentation:")
	  (terpri)
	  (let ((doc (documentation-property variable 'variable-documentation)))
	    (princ (or doc "not documented as a variable.")))
          (help-setup-xref (list #'describe-variable variable (current-buffer))
			   (interactive-p))
	  
	  ;; Make a link to customize if this variable can be customized.
	  ;; Note, it is not reliable to test only for a custom-type property
	  ;; because those are only present after the var's definition
	  ;; has been loaded.
	  (if (or (get variable 'custom-type) ; after defcustom
		  (get variable 'custom-loads) ; from loaddefs.el
		  (get variable 'standard-value)) ; from cus-start.el
	      (let ((customize-label "customize"))
		(terpri)
		(terpri)
		(princ (concat "You can " customize-label " 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)))))
	  ;; Make a hyperlink to the library if appropriate.  (Don't
	  ;; change the format of the buffer's initial line in case
	  ;; anything expects the current format.)
	  (let ((file-name (symbol-file variable)))
	    (when (equal file-name "loaddefs.el")
	      ;; Find the real def site of the preloaded variable.
	      (let ((location
		     (condition-case nil
			 (find-variable-noselect variable file-name)
		       (error nil))))
		(when location
		  (with-current-buffer (car location)
		    (goto-char (cdr location))
		    (when (re-search-backward
			   "^;;; Generated autoloads from \\(.*\\)" nil t)
		      (setq file-name (match-string 1)))))))
	    (when file-name
	      (princ "\n\nDefined in `")
	      (princ file-name)
	      (princ "'.")
	      (with-current-buffer standard-output
		(save-excursion
		  (re-search-backward "`\\([^`']+\\)'" nil t)
		  (help-xref-button 1 'help-variable-def
				    variable file-name)))))

	  (print-help-return-message)
	  (save-excursion
	    (set-buffer standard-output)
	    ;; Return the text we displayed.
	    (buffer-string)))))))


;; `help-manyarg-func-alist' is defined primitively (in doc.c).
;; New primitives with `MANY' or `UNEVALLED' arglists should be added
;; to this alist.
;; The parens and function name are redundant, but it's messy to add
;; them in `documentation'.

;; This will find any missing items:
;; (let (l)
;;   (mapatoms (lambda (x)
;; 	      (if (and (fboundp x)
;; 		       (subrp (symbol-function x))
;; 		       (not (numberp (cdr (subr-arity (symbol-function x)))))
;; 		       (not (assq x help-manyarg-func-alist)))
;; 		  (push x l))))
;;   l)
(defconst help-manyarg-func-alist
  (purecopy
   '((list . "(list &rest OBJECTS)")
     (vector . "(vector &rest OBJECTS)")
     (make-byte-code . "(make-byte-code &rest ELEMENTS)")
     (call-process
      . "(call-process PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS)")
     (call-process-region
      . "(call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &rest ARGS)")
     (string . "(string &rest CHARACTERS)")
     (+ . "(+ &rest NUMBERS-OR-MARKERS)")
     (- . "(- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS)")
     (* . "(* &rest NUMBERS-OR-MARKERS)")
     (/ . "(/ DIVIDEND DIVISOR &rest DIVISORS)")
     (max . "(max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)")
     (min . "(min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)")
     (logand . "(logand &rest INTS-OR-MARKERS)")
     (logior . "(logior &rest INTS-OR-MARKERS)")
     (logxor . "(logxor &rest INTS-OR-MARKERS)")
     (encode-time
      . "(encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE)")
     (insert . "(insert &rest ARGS)")
     (insert-and-inherit . "(insert-and-inherit &rest ARGS)")
     (insert-before-markers . "(insert-before-markers &rest ARGS)")
     (message . "(message STRING &rest ARGUMENTS)")
     (message-box . "(message-box STRING &rest ARGUMENTS)")
     (message-or-box . "(message-or-box STRING &rest ARGUMENTS)")
     (propertize . "(propertize STRING &rest PROPERTIES)")
     (format . "(format STRING &rest OBJECTS)")
     (apply . "(apply FUNCTION &rest ARGUMENTS)")
     (run-hooks . "(run-hooks &rest HOOKS)")
     (run-hook-with-args . "(run-hook-with-args HOOK &rest ARGS)")
     (run-hook-with-args-until-failure
      . "(run-hook-with-args-until-failure HOOK &rest ARGS)")
     (run-hook-with-args-until-success
      . "(run-hook-with-args-until-success HOOK &rest ARGS)")
     (funcall . "(funcall FUNCTION &rest ARGUMENTS)")
     (append . "(append &rest SEQUENCES)")
     (concat . "(concat &rest SEQUENCES)")
     (vconcat . "(vconcat &rest SEQUENCES)")
     (nconc . "(nconc &rest LISTS)")
     (widget-apply . "(widget-apply WIDGET PROPERTY &rest ARGS)")
     (make-hash-table . "(make-hash-table &rest KEYWORD-ARGS)")
     (insert-string . "(insert-string &rest ARGS)")
     (start-process . "(start-process NAME BUFFER PROGRAM &rest PROGRAM-ARGS)")
     (setq-default . "(setq-default SYMBOL VALUE [SYMBOL VALUE...])")
     (save-excursion . "(save-excursion &rest BODY)")
     (save-current-buffer . "(save-current-buffer &rest BODY)")
     (save-restriction . "(save-restriction &rest BODY)")
     (or . "(or CONDITIONS ...)")
     (and . "(and CONDITIONS ...)")
     (if . "(if COND THEN ELSE...)")
     (cond . "(cond CLAUSES...)")
     (progn . "(progn BODY ...)")
     (prog1 . "(prog1 FIRST BODY...)")
     (prog2 . "(prog2 X Y BODY...)")
     (setq . "(setq SYM VAL SYM VAL ...)")
     (quote . "(quote ARG)")
     (function . "(function ARG)")
     (defun . "(defun NAME ARGLIST [DOCSTRING] BODY...)")
     (defmacro . "(defmacro NAME ARGLIST [DOCSTRING] BODY...)")
     (defvar . "(defvar SYMBOL [INITVALUE DOCSTRING])")
     (defconst . "(defconst SYMBOL INITVALUE [DOCSTRING])")
     (let* . "(let* VARLIST BODY...)")
     (let . "(let VARLIST BODY...)")
     (while . "(while TEST BODY...)")
     (catch . "(catch TAG BODY...)")
     (unwind-protect . "(unwind-protect BODYFORM UNWINDFORMS...)")
     (condition-case . "(condition-case VAR BODYFORM HANDLERS...)")
     (track-mouse . "(track-mouse BODY ...)")
     (ml-if . "(ml-if COND THEN ELSE...)")
     (ml-provide-prefix-argument . "(ml-provide-prefix-argument ARG1 ARG2)")
     (ml-prefix-argument-loop . "(ml-prefix-argument-loop ...)")
     (with-output-to-temp-buffer
	 . "(with-output-to-temp-buffer BUFFNAME BODY ...)")
     (save-window-excursion . "(save-window-excursion BODY ...)")
     (find-operation-coding-system
      . "(find-operation-coding-system OPERATION ARGUMENTS ...)")
     (insert-before-markers-and-inherit
      . "(insert-before-markers-and-inherit &rest ARGS)"))))


(provide 'help-funs)

;;; help-funs.el ends here