(or (featurep 'timer)
(load "timer" t))
(defgroup eldoc nil
"Show function arglist or variable docstring in echo area."
:group 'lisp
:group 'extensions)
(defcustom eldoc-mode nil
"*If non-nil, show the defined parameters for the elisp function near point.
For the emacs lisp function at the beginning of the sexp which point is
within, show the defined parameters for the function in the echo area.
This information is extracted directly from the function or macro if it is
in pure lisp. If the emacs function is a subr, the parameters are obtained
from the documentation string if possible.
If point is over a documented variable, print that variable's docstring
instead.
This variable is buffer-local."
:type 'boolean
:group 'eldoc)
(make-variable-buffer-local 'eldoc-mode)
(defcustom eldoc-idle-delay 0.50
"*Number of seconds of idle time to wait before printing.
If user input arrives before this interval of time has elapsed after the
last input, no documentation will be printed.
If this variable is set to 0, no idle time is required."
:type 'number
:group 'eldoc)
(defcustom eldoc-minor-mode-string " ElDoc"
"*String to display in mode line when Eldoc Mode is enabled."
:type 'string
:group 'eldoc)
(defcustom eldoc-argument-case 'upcase
"Case to display argument names of functions, as a symbol.
This has two preferred values: `upcase' or `downcase'.
Actually, any name of a function which takes a string as an argument and
returns another string is acceptable."
:type '(radio (function-item upcase)
(function-item downcase)
function)
:group 'eldoc)
(defcustom eldoc-echo-area-use-multiline-p 'truncate-sym-name-if-fit
"*Allow long eldoc messages to resize echo area display.
If value is `t', never attempt to truncate messages; complete symbol name
and function arglist or 1-line variable documentation will be displayed
even if echo area must be resized to fit.
If value is any non-nil value other than `t', symbol name may be truncated
if it will enable the function arglist or documentation string to fit on a
single line without resizing window. Otherwise, behavior is just like
former case.
If value is nil, messages are always truncated to fit in a single line of
display in the echo area. Function or variable symbol name may be
truncated to make more of the arglist or documentation string visible.
Non-nil values for this variable have no effect unless
`eldoc-echo-area-multiline-supported-p' is non-nil."
:type '(radio (const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "Yes, but truncate symbol names if it will\
enable argument list to fit on one line" truncate-sym-name-if-fit))
:group 'eldoc)
(defvar eldoc-echo-area-multiline-supported-p
(and (string-lessp "21" emacs-version)
(save-match-data
(numberp (string-match "^GNU Emacs" (emacs-version))))))
(defvar eldoc-message-commands nil)
(defvar eldoc-message-commands-table-size 31)
(defvar eldoc-last-data (make-vector 3 nil))
(defvar eldoc-last-message nil)
(defvar eldoc-use-idle-timer-p (fboundp 'run-with-idle-timer))
(defvar eldoc-timer nil)
(defvar eldoc-current-idle-delay eldoc-idle-delay)
(cond ((fboundp 'add-minor-mode)
(add-minor-mode 'eldoc-mode 'eldoc-minor-mode-string))
((assq 'eldoc-mode (default-value 'minor-mode-alist)))
(t
(setq-default minor-mode-alist
(append (default-value 'minor-mode-alist)
'((eldoc-mode eldoc-minor-mode-string))))))
(defun eldoc-mode (&optional prefix)
"*Enable or disable eldoc mode.
See documentation for the variable of the same name for more details.
If called interactively with no prefix argument, toggle current condition
of the mode.
If called with a positive or negative prefix argument, enable or disable
the mode, respectively."
(interactive "P")
(setq eldoc-last-message nil)
(cond (eldoc-use-idle-timer-p
(add-hook 'post-command-hook 'eldoc-schedule-timer)
(add-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area))
(t
(add-hook (if (boundp 'post-command-idle-hook)
'post-command-idle-hook
'post-command-hook)
'eldoc-print-current-symbol-info t t)
(and (fboundp 'display-message)
(add-hook 'pre-command-hook
'eldoc-pre-command-refresh-echo-area t t))))
(setq eldoc-mode (if prefix
(>= (prefix-numeric-value prefix) 0)
(not eldoc-mode)))
(and (interactive-p)
(if eldoc-mode
(message "eldoc-mode is enabled")
(message "eldoc-mode is disabled")))
eldoc-mode)
(defun turn-on-eldoc-mode ()
"Unequivocally turn on eldoc-mode (see variable documentation)."
(interactive)
(eldoc-mode 1))
(defun eldoc-schedule-timer ()
(or (and eldoc-timer
(memq eldoc-timer timer-idle-list))
(setq eldoc-timer
(run-with-idle-timer eldoc-idle-delay t
'eldoc-print-current-symbol-info)))
(cond ((not (= eldoc-idle-delay eldoc-current-idle-delay))
(setq eldoc-current-idle-delay eldoc-idle-delay)
(timer-set-idle-time eldoc-timer eldoc-idle-delay t))))
(defun eldoc-message (&rest args)
(let ((omessage eldoc-last-message))
(cond ((eq (car args) eldoc-last-message))
((or (null args)
(null (car args)))
(setq eldoc-last-message nil))
((null (cdr args))
(setq eldoc-last-message (car args)))
(t
(setq eldoc-last-message (apply 'format args))))
(cond ((fboundp 'display-message)
(cond (eldoc-last-message
(display-message 'no-log eldoc-last-message))
(omessage
(clear-message 'no-log))))
(t
(let ((message-log-max nil))
(cond (eldoc-last-message
(message "%s" eldoc-last-message))
(omessage
(message nil)))))))
eldoc-last-message)
(defun eldoc-pre-command-refresh-echo-area ()
(and eldoc-last-message
(if (eldoc-display-message-no-interference-p)
(eldoc-message eldoc-last-message)
(setq eldoc-last-message nil))))
(defun eldoc-display-message-p ()
(and (eldoc-display-message-no-interference-p)
(cond (eldoc-use-idle-timer-p
(and (not this-command)
(symbolp last-command)
(intern-soft (symbol-name last-command)
eldoc-message-commands)))
(t
(and (symbolp this-command)
(intern-soft (symbol-name this-command)
eldoc-message-commands)
(sit-for eldoc-idle-delay))))))
(defun eldoc-display-message-no-interference-p ()
(and eldoc-mode
(not executing-kbd-macro)
(not (and (boundp 'edebug-active) edebug-active))
(not cursor-in-echo-area)
(not (eq (selected-window) (minibuffer-window)))))
(defun eldoc-print-current-symbol-info ()
(and (eldoc-display-message-p)
(let* ((current-symbol (eldoc-current-symbol))
(current-fnsym (eldoc-fnsym-in-current-sexp))
(doc (cond ((eq current-symbol current-fnsym)
(or (eldoc-get-fnsym-args-string current-fnsym)
(eldoc-get-var-docstring current-symbol)))
(t
(or (eldoc-get-var-docstring current-symbol)
(eldoc-get-fnsym-args-string current-fnsym))))))
(eldoc-message doc))))
(defun eldoc-get-fnsym-args-string (sym)
(let ((args nil)
(doc nil))
(cond ((not (and sym
(symbolp sym)
(fboundp sym))))
((and (eq sym (aref eldoc-last-data 0))
(eq 'function (aref eldoc-last-data 2)))
(setq doc (aref eldoc-last-data 1)))
((subrp (eldoc-symbol-function sym))
(setq args (or (eldoc-function-argstring-from-docstring sym)
(eldoc-docstring-first-line (documentation sym t)))))
(t
(setq args (eldoc-function-argstring sym))))
(cond (args
(setq doc (eldoc-docstring-format-sym-doc sym args))
(eldoc-last-data-store sym doc 'function)))
doc))
(defun eldoc-get-var-docstring (sym)
(cond ((and (eq sym (aref eldoc-last-data 0))
(eq 'variable (aref eldoc-last-data 2)))
(aref eldoc-last-data 1))
(t
(let ((doc (documentation-property sym 'variable-documentation t)))
(cond (doc
(setq doc (eldoc-docstring-format-sym-doc
sym (eldoc-docstring-first-line doc)))
(eldoc-last-data-store sym doc 'variable)))
doc))))
(defun eldoc-last-data-store (symbol doc type)
(aset eldoc-last-data 0 symbol)
(aset eldoc-last-data 1 doc)
(aset eldoc-last-data 2 type))
(defun eldoc-docstring-first-line (doc)
(and (stringp doc)
(substitute-command-keys
(save-match-data
(let ((start (if (string-match "^\\*" doc) (match-end 0) 0)))
(cond ((string-match "\n" doc)
(substring doc start (match-beginning 0)))
((zerop start) doc)
(t (substring doc start))))))))
(defun eldoc-docstring-format-sym-doc (sym doc)
(save-match-data
(let* ((name (symbol-name sym))
(ea-multi (and eldoc-echo-area-multiline-supported-p
eldoc-echo-area-use-multiline-p))
(ea-width (1- (window-width (minibuffer-window))))
(strip (- (+ (length name) (length ": ") (length doc)) ea-width)))
(cond ((or (<= strip 0)
(eq ea-multi t)
(and ea-multi (> (length doc) ea-width)))
(format "%s: %s" sym doc))
((> (length doc) ea-width)
(substring (format "%s" doc) 0 ea-width))
((>= strip (length name))
(format "%s" doc))
(t
(setq name (substring name strip))
(format "%s: %s" name doc))))))
(defun eldoc-fnsym-in-current-sexp ()
(let ((p (point)))
(eldoc-beginning-of-sexp)
(prog1
(if (= (or (char-after (1- (point))) 0) ?\")
nil
(eldoc-current-symbol))
(goto-char p))))
(defun eldoc-beginning-of-sexp ()
(let ((parse-sexp-ignore-comments t))
(condition-case err
(while (progn
(forward-sexp -1)
(or (= (or (char-after (1- (point)))) ?\")
(> (point) (point-min)))))
(error nil))))
;; returns nil unless current word is an interned symbol.
(defun eldoc-current-symbol ()
(let ((c (char-after (point))))
(and c
(memq (char-syntax c) '(?w ?_))
(intern-soft (current-word)))))
;; Do indirect function resolution if possible.
(defun eldoc-symbol-function (fsym)
(let ((defn (and (fboundp fsym)
(symbol-function fsym))))
(and (symbolp defn)
(condition-case err
(setq defn (indirect-function fsym))
(error (setq defn nil))))
defn))
(defun eldoc-function-arglist (fn)
(let* ((prelim-def (eldoc-symbol-function fn))
(def (if (eq (car-safe prelim-def) 'macro)
(cdr prelim-def)
prelim-def))
(arglist (cond ((null def) nil)
((byte-code-function-p def)
(cond ((fboundp 'compiled-function-arglist)
(funcall 'compiled-function-arglist def))
(t
(aref def 0))))
((eq (car-safe def) 'lambda)
(nth 1 def))
(t t))))
arglist))
(defun eldoc-function-argstring (fn)
(eldoc-function-argstring-format (eldoc-function-arglist fn)))
(defun eldoc-function-argstring-format (arglist)
(cond ((not (listp arglist))
(setq arglist nil))
((symbolp (car arglist))
(setq arglist
(mapcar (function (lambda (s)
(if (memq s '(&optional &rest))
(symbol-name s)
(funcall eldoc-argument-case
(symbol-name s)))))
arglist)))
((stringp (car arglist))
(setq arglist
(mapcar (function (lambda (s)
(if (member s '("&optional" "&rest"))
s
(funcall eldoc-argument-case s))))
arglist))))
(concat "(" (mapconcat 'identity arglist " ") ")"))
;; Alist of predicate/action pairs.
;; Each member of the list is a sublist consisting of a predicate function
;; used to determine if the arglist for a function can be found using a
;; certain pattern, and a function which returns the actual arglist from
;; that docstring.
;;
;; The order in this table is significant, since later predicates may be
;; more general than earlier ones.
;;
;; Compiler note for Emacs/XEmacs versions which support dynamic loading:
;; these functions will be compiled to bytecode, but can't be lazy-loaded
;; even if you set byte-compile-dynamic; to do that would require making
;; them named top-level defuns, which is not particularly desirable either.
(defvar eldoc-function-argstring-from-docstring-method-table
(list
;; Try first searching for args starting with symbol name.
;; This is to avoid matching parenthetical remarks in e.g. sit-for.
(list (function (lambda (doc fn)
(string-match (format "^(%s[^\n)]*)$" fn) doc)))
(function (lambda (doc)
;; end does not include trailing ")" sequence.
(let ((end (- (match-end 0) 1)))
(if (string-match " +" doc (match-beginning 0))
(substring doc (match-end 0) end)
"")))))
;; Try again not requiring this symbol name in the docstring.
;; This will be the case when looking up aliases.
(list (function (lambda (doc fn)
;; save-restriction has a pathological docstring in
;; Emacs/XEmacs 19.
(and (not (eq fn 'save-restriction))
(string-match "^([^\n)]+)$" doc))))
(function (lambda (doc)
;; end does not include trailing ")" sequence.
(let ((end (- (match-end 0) 1)))
(and (string-match " +" doc (match-beginning 0))
(substring doc (match-end 0) end))))))
;; Emacs subr docstring style:
;; (fn arg1 arg2 ...): description...
(list (function (lambda (doc fn)
(string-match "^([^\n)]+):" doc)))
(function (lambda (doc)
;; end does not include trailing "):" sequence.
(let ((end (- (match-end 0) 2)))
(and (string-match " +" doc (match-beginning 0))
(substring doc (match-end 0) end))))))
;; XEmacs subr docstring style:
;; "arguments: (arg1 arg2 ...)
(list (function (lambda (doc fn)
(string-match "^arguments: (\\([^\n)]+\\))" doc)))
(function (lambda (doc)
(substring doc (match-beginning 1) (match-end 1)))))
(list (function (lambda (doc fn)
(string-match
(format "^Usage looks like \\((%s[^\n)]*)\\)\\.$" fn)
doc)))
(function (lambda (doc)
(let ((end (- (match-end 1) 1)))
(and (string-match " +" doc (match-beginning 1))
(substring doc (match-end 0) end))))))
(list (function (lambda (doc fn)
(string-match (format "^[ \t]+\\((%s[^\n)]*)\\)$" fn)
doc)))
(function (lambda (doc)
(let ((end (- (match-end 1) 1)))
(and (string-match " +" doc (match-beginning 1))
(substring doc (match-end 0) end))))))
(list (function (lambda (doc fn)
(string-match "^Args are +\\([^\n]+\\)$" doc)))
(function (lambda (doc)
(substring doc (match-beginning 1) (match-end 1)))))
(list (function (lambda (doc fn)
(memq fn '(and or list + -))))
(function (lambda (doc)
nil
"&rest args")))
))
(defun eldoc-function-argstring-from-docstring (fn)
(let ((docstring (documentation fn 'raw))
(table eldoc-function-argstring-from-docstring-method-table)
(doc nil)
(doclist nil))
(save-match-data
(while table
(cond ((funcall (car (car table)) docstring fn)
(setq doc (funcall (car (cdr (car table))) docstring))
(setq table nil))
(t
(setq table (cdr table)))))
(cond ((not (stringp doc))
nil)
((string-match "&" doc)
(let ((p 0)
(l (length doc)))
(while (< p l)
(cond ((string-match "[ \t\n]+" doc p)
(setq doclist
(cons (substring doc p (match-beginning 0))
doclist))
(setq p (match-end 0)))
(t
(setq doclist (cons (substring doc p) doclist))
(setq p l))))
(eldoc-function-argstring-format (nreverse doclist))))
(t
(concat "(" (funcall eldoc-argument-case doc) ")"))))))
(defun eldoc-add-command (&rest cmds)
(or eldoc-message-commands
(setq eldoc-message-commands
(make-vector eldoc-message-commands-table-size 0)))
(let (name sym)
(while cmds
(setq name (car cmds))
(setq cmds (cdr cmds))
(cond ((symbolp name)
(setq sym name)
(setq name (symbol-name sym)))
((stringp name)
(setq sym (intern-soft name))))
(and (symbolp sym)
(fboundp sym)
(set (intern name eldoc-message-commands) t)))))
(defun eldoc-add-command-completions (&rest names)
(while names
(apply 'eldoc-add-command
(all-completions (car names) obarray 'fboundp))
(setq names (cdr names))))
(defun eldoc-remove-command (&rest cmds)
(let (name)
(while cmds
(setq name (car cmds))
(setq cmds (cdr cmds))
(and (symbolp name)
(setq name (symbol-name name)))
(if (fboundp 'unintern)
(unintern name eldoc-message-commands)
(let ((s (intern-soft name eldoc-message-commands)))
(and s
(makunbound s)))))))
(defun eldoc-remove-command-completions (&rest names)
(while names
(apply 'eldoc-remove-command
(all-completions (car names) eldoc-message-commands))
(setq names (cdr names))))
(eldoc-add-command-completions
"backward-" "beginning-of-" "delete-other-windows" "delete-window"
"end-of-" "forward-" "indent-for-tab-command" "goto-" "mouse-set-point"
"next-" "other-window" "previous-" "recenter" "scroll-"
"self-insert-command" "split-window-"
"up-list" "down-list")
(provide 'eldoc)