;;; lisp.el --- Lisp editing commands for Emacs -*- lexical-binding:t -*-
-;; Copyright (C) 1985-1986, 1994, 2000-2014 Free Software Foundation,
+;; Copyright (C) 1985-1986, 1994, 2000-2015 Free Software Foundation,
;; Inc.
;; Maintainer: emacs-devel@gnu.org
(beginning-of-defun))
(re-search-backward "^\n" (- (point) 1) t)))))
-(defun narrow-to-defun (&optional _arg)
+(defvar narrow-to-defun-include-comments nil
+ "If non-nil, `narrow-to-defun' will also show comments preceding the defun.")
+
+(defun narrow-to-defun (&optional include-comments)
"Make text outside current defun invisible.
-The defun visible is the one that contains point or follows point.
-Optional ARG is ignored."
- (interactive)
+The current defun is the one that contains point or follows point.
+Preceding comments are included if INCLUDE-COMMENTS is non-nil.
+Interactively, the behavior depends on `narrow-to-defun-include-comments'."
+ (interactive (list narrow-to-defun-include-comments))
(save-excursion
(widen)
(let ((opoint (point))
(setq end (point))
(beginning-of-defun)
(setq beg (point)))
+ (when include-comments
+ (goto-char beg)
+ ;; Move back past all preceding comments (and whitespace).
+ (when (forward-comment -1)
+ (while (forward-comment -1))
+ ;; Move forwards past any page breaks within these comments.
+ (when (and page-delimiter (not (string= page-delimiter "")))
+ (while (re-search-forward page-delimiter beg t)))
+ ;; Lastly, move past any empty lines.
+ (skip-chars-forward "[:space:]\n")
+ (beginning-of-line)
+ (setq beg (point))))
(goto-char end)
(re-search-backward "^\n" (- (point) 1) t)
(narrow-to-region beg end))))
(completion-in-region (nth 0 data) (nth 1 data) (nth 2 data)
(plist-get plist :predicate))))))
-(defun lisp--local-variables-1 (vars sexp)
- "Return the vars locally bound around the witness, or nil if not found."
- (let (res)
- (while
- (unless
- (setq res
- (pcase sexp
- (`(,(or `let `let*) ,bindings)
- (let ((vars vars))
- (when (eq 'let* (car sexp))
- (dolist (binding (cdr (reverse bindings)))
- (push (or (car-safe binding) binding) vars)))
- (lisp--local-variables-1
- vars (car (cdr-safe (car (last bindings)))))))
- (`(,(or `let `let*) ,bindings . ,body)
- (let ((vars vars))
- (dolist (binding bindings)
- (push (or (car-safe binding) binding) vars))
- (lisp--local-variables-1 vars (car (last body)))))
- (`(lambda ,_) (setq sexp nil))
- (`(lambda ,args . ,body)
- (lisp--local-variables-1
- (append args vars) (car (last body))))
- (`(condition-case ,_ ,e) (lisp--local-variables-1 vars e))
- (`(condition-case ,v ,_ . ,catches)
- (lisp--local-variables-1
- (cons v vars) (cdr (car (last catches)))))
- (`(,_ . ,_)
- (lisp--local-variables-1 vars (car (last sexp))))
- (`lisp--witness--lisp (or vars '(nil)))
- (_ nil)))
- (setq sexp (ignore-errors (butlast sexp)))))
- res))
-
-(defun lisp--local-variables ()
- "Return a list of locally let-bound variables at point."
- (save-excursion
- (skip-syntax-backward "w_")
- (let* ((ppss (syntax-ppss))
- (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point))
- (or (nth 8 ppss) (point))))
- (closer ()))
- (dolist (p (nth 9 ppss))
- (push (cdr (syntax-after p)) closer))
- (setq closer (apply #'string closer))
- (let* ((sexp (condition-case nil
- (car (read-from-string
- (concat txt "lisp--witness--lisp" closer)))
- (end-of-file nil)))
- (macroexpand-advice (lambda (expander form &rest args)
- (condition-case nil
- (apply expander form args)
- (error form))))
- (sexp
- (unwind-protect
- (progn
- (advice-add 'macroexpand :around macroexpand-advice)
- (macroexpand-all sexp))
- (advice-remove 'macroexpand macroexpand-advice)))
- (vars (lisp--local-variables-1 nil sexp)))
- (delq nil
- (mapcar (lambda (var)
- (and (symbolp var)
- (not (string-match (symbol-name var) "\\`[&_]"))
- ;; Eliminate uninterned vars.
- (intern-soft var)
- var))
- vars))))))
-
-(defvar lisp--local-variables-completion-table
- ;; Use `defvar' rather than `defconst' since defconst would purecopy this
- ;; value, which would doubly fail: it would fail because purecopy can't
- ;; handle the recursive bytecode object, and it would fail because it would
- ;; move `lastpos' and `lastvars' to pure space where they'd be immutable!
- (let ((lastpos nil) (lastvars nil))
- (letrec ((hookfun (lambda ()
- (setq lastpos nil)
- (remove-hook 'post-command-hook hookfun))))
- (completion-table-dynamic
- (lambda (_string)
- (save-excursion
- (skip-syntax-backward "_w")
- (let ((newpos (cons (point) (current-buffer))))
- (unless (equal lastpos newpos)
- (add-hook 'post-command-hook hookfun)
- (setq lastpos newpos)
- (setq lastvars
- (mapcar #'symbol-name (lisp--local-variables))))))
- lastvars)))))
-
-;; FIXME: Support for Company brings in features which straddle eldoc.
-;; We should consolidate this, so that major modes can provide all that
-;; data all at once:
-;; - a function to extract "the reference at point" (may be more complex
-;; than a mere string, to distinguish various namespaces).
-;; - a function to jump to such a reference.
-;; - a function to show the signature/interface of such a reference.
-;; - a function to build a help-buffer about that reference.
-;; FIXME: Those functions should also be used by the normal completion code in
-;; the *Completions* buffer.
-
-(defun lisp--company-doc-buffer (str)
- (let ((symbol (intern-soft str)))
- ;; FIXME: we really don't want to "display-buffer and then undo it".
- (save-window-excursion
- ;; Make sure we don't display it in another frame, otherwise
- ;; save-window-excursion won't be able to undo it.
- (let ((display-buffer-overriding-action
- '(nil . ((inhibit-switch-frame . t)))))
- (ignore-errors
- (cond
- ((fboundp symbol) (describe-function symbol))
- ((boundp symbol) (describe-variable symbol))
- ((featurep symbol) (describe-package symbol))
- ((facep symbol) (describe-face symbol))
- (t (signal 'user-error nil)))
- (help-buffer))))))
-
-(defun lisp--company-doc-string (str)
- (let* ((symbol (intern-soft str))
- (doc (if (fboundp symbol)
- (documentation symbol t)
- (documentation-property symbol 'variable-documentation t))))
- (and (stringp doc)
- (string-match ".*$" doc)
- (match-string 0 doc))))
-
-(declare-function find-library-name "find-func" (library))
-
-(defun lisp--company-location (str)
- (let ((sym (intern-soft str)))
- (cond
- ((fboundp sym) (find-definition-noselect sym nil))
- ((boundp sym) (find-definition-noselect sym 'defvar))
- ((featurep sym)
- (require 'find-func)
- (cons (find-file-noselect (find-library-name
- (symbol-name sym)))
- 0))
- ((facep sym) (find-definition-noselect sym 'defface)))))
-
-(defun lisp-completion-at-point (&optional _predicate)
- "Function used for `completion-at-point-functions' in `emacs-lisp-mode'."
- (with-syntax-table emacs-lisp-mode-syntax-table
- (let* ((pos (point))
- (beg (condition-case nil
- (save-excursion
- (backward-sexp 1)
- (skip-syntax-forward "'")
- (point))
- (scan-error pos)))
- (end
- (unless (or (eq beg (point-max))
- (member (char-syntax (char-after beg))
- '(?\s ?\" ?\( ?\))))
- (condition-case nil
- (save-excursion
- (goto-char beg)
- (forward-sexp 1)
- (when (>= (point) pos)
- (point)))
- (scan-error pos))))
- (funpos (eq (char-before beg) ?\()) ;t if in function position.
- (table-etc
- (if (not funpos)
- ;; FIXME: We could look at the first element of the list and
- ;; use it to provide a more specific completion table in some
- ;; cases. E.g. filter out keywords that are not understood by
- ;; the macro/function being called.
- (list nil (completion-table-merge
- lisp--local-variables-completion-table
- (apply-partially #'completion-table-with-predicate
- obarray
- ;; Don't include all symbols
- ;; (bug#16646).
- (lambda (sym)
- (or (boundp sym)
- (fboundp sym)
- (symbol-plist sym)))
- 'strict))
- :annotation-function
- (lambda (str) (if (fboundp (intern-soft str)) " <f>"))
- :company-doc-buffer #'lisp--company-doc-buffer
- :company-docsig #'lisp--company-doc-string
- :company-location #'lisp--company-location)
- ;; Looks like a funcall position. Let's double check.
- (save-excursion
- (goto-char (1- beg))
- (let ((parent
- (condition-case nil
- (progn (up-list -1) (forward-char 1)
- (let ((c (char-after)))
- (if (eq c ?\() ?\(
- (if (memq (char-syntax c) '(?w ?_))
- (read (current-buffer))))))
- (error nil))))
- (pcase parent
- ;; FIXME: Rather than hardcode special cases here,
- ;; we should use something like a symbol-property.
- (`declare
- (list t (mapcar (lambda (x) (symbol-name (car x)))
- (delete-dups
- ;; FIXME: We should include some
- ;; docstring with each entry.
- (append
- macro-declarations-alist
- defun-declarations-alist)))))
- ((and (or `condition-case `condition-case-unless-debug)
- (guard (save-excursion
- (ignore-errors
- (forward-sexp 2)
- (< (point) beg)))))
- (list t obarray
- :predicate (lambda (sym) (get sym 'error-conditions))))
- ((and ?\(
- (guard (save-excursion
- (goto-char (1- beg))
- (up-list -1)
- (forward-symbol -1)
- (looking-at "\\_<let\\*?\\_>"))))
- (list t obarray
- :predicate #'boundp
- :company-doc-buffer #'lisp--company-doc-buffer
- :company-docsig #'lisp--company-doc-string
- :company-location #'lisp--company-location))
- (_ (list nil obarray
- :predicate #'fboundp
- :company-doc-buffer #'lisp--company-doc-buffer
- :company-docsig #'lisp--company-doc-string
- :company-location #'lisp--company-location
- ))))))))
- (when end
- (let ((tail (if (null (car table-etc))
- (cdr table-etc)
- (cons
- (if (memq (char-syntax (or (char-after end) ?\s))
- '(?\s ?>))
- (cadr table-etc)
- (apply-partially 'completion-table-with-terminator
- " " (cadr table-etc)))
- (cddr table-etc)))))
- `(,beg ,end ,@tail))))))
-
;;; lisp.el ends here