X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/fa2930ab25d48b66e66f4fab283649dd6833fbeb..170111814c0bd342c50ab84d3e3bf699c1bd1f1d:/packages/company/company-elisp.el

diff --git a/packages/company/company-elisp.el b/packages/company/company-elisp.el
index b4a3aa36e..5efd8d051 100644
--- a/packages/company/company-elisp.el
+++ b/packages/company/company-elisp.el
@@ -1,6 +1,6 @@
-;;; company-elisp.el --- A company-mode completion back-end for emacs-lisp-mode
+;;; company-elisp.el --- company-mode completion back-end for Emacs Lisp -*- lexical-binding: t -*-
 
-;; Copyright (C) 2009, 2011  Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011-2013  Free Software Foundation, Inc.
 
 ;; Author: Nikolaj Schumacher
 
@@ -21,89 +21,168 @@
 
 
 ;;; Commentary:
-;; 
+;;
 
 ;;; Code:
 
 (require 'company)
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
 (require 'help-mode)
+(require 'find-func)
+
+(defgroup company-elisp nil
+  "Completion back-end for Emacs Lisp."
+  :group 'company)
 
 (defcustom company-elisp-detect-function-context t
-  "*If enabled, offer Lisp functions only in appropriate contexts.
+  "If enabled, offer Lisp functions only in appropriate contexts.
 Functions are offered for completion only after ' and \(."
-  :group 'company
   :type '(choice (const :tag "Off" nil)
                  (const :tag "On" t)))
 
-(defun company-grab-lisp-symbol ()
+(defcustom company-elisp-show-locals-first t
+  "If enabled, locally bound variables and functions are displayed
+first in the candidates list."
+  :type '(choice (const :tag "Off" nil)
+                 (const :tag "On" t)))
+
+(defun company-elisp--prefix ()
   (let ((prefix (company-grab-symbol)))
     (if prefix
-        (unless (and (company-in-string-or-comment)
-                     (/= (char-before (- (point) (length prefix))) ?`))
+        (when (if (company-in-string-or-comment)
+                  (= (char-before (- (point) (length prefix))) ?`)
+                (company-elisp--should-complete))
           prefix)
       'stop)))
 
-(defun company-elisp-predicate (symbol)
+(defun company-elisp--predicate (symbol)
   (or (boundp symbol)
-      (fboundp symbol)))
+      (fboundp symbol)
+      (facep symbol)
+      (featurep symbol)))
+
+(defun company-elisp--fns-regexp (&rest names)
+  (concat "\\_<\\(?:cl-\\)?" (regexp-opt names) "\\*?\\_>"))
 
 (defvar company-elisp-parse-limit 30)
 (defvar company-elisp-parse-depth 100)
 
-(defvar company-elisp-binding-regexp
-  (concat "([ \t\n]*\\_<" (regexp-opt '("let" "defun" "defmacro" "defsubst"
-                                        "lambda" "lexical-let" "flet" "labels"))
-          "\\*?")
-  "Regular expression matching sexps containing variable bindings.")
-
-(defvar company-elisp-binding-regexp-1
-  (concat "([ \t\n]*\\_<" (regexp-opt '("dolist" "dotimes")))
-  "Regular expression matching sexps containing one variable binding.")
-
-(defun company-elisp-parse-local (prefix vars)
+(defvar company-elisp-defun-names '("defun" "defmacro" "defsubst"))
+
+(defvar company-elisp-var-binding-regexp
+  (apply #'company-elisp--fns-regexp "let" "lambda" "lexical-let"
+         company-elisp-defun-names)
+  "Regular expression matching head of a multiple variable bindings form.")
+
+(defvar company-elisp-var-binding-regexp-1
+  (company-elisp--fns-regexp "dolist" "dotimes")
+  "Regular expression matching head of a form with one variable binding.")
+
+(defvar company-elisp-fun-binding-regexp
+  (company-elisp--fns-regexp "flet" "labels")
+  "Regular expression matching head of a function bindings form.")
+
+(defvar company-elisp-defuns-regexp
+  (concat "([ \t\n]*"
+          (apply #'company-elisp--fns-regexp company-elisp-defun-names)))
+
+(defun company-elisp--should-complete ()
+  (let ((start (point))
+        (depth (car (syntax-ppss))))
+    (not
+     (when (> depth 0)
+       (save-excursion
+         (up-list (- depth))
+         (when (looking-at company-elisp-defuns-regexp)
+           (forward-char)
+           (forward-sexp 1)
+           (unless (= (point) start)
+             (condition-case nil
+                 (let ((args-end (scan-sexps (point) 2)))
+                   (or (null args-end)
+                       (> args-end start)))
+               (scan-error
+                t)))))))))
+
+(defun company-elisp--locals (prefix functions-p)
   (let ((regexp (concat "[ \t\n]*\\(\\_<" (regexp-quote prefix)
                         "\\(?:\\sw\\|\\s_\\)*\\_>\\)"))
-        (pos (point)))
-    (ignore-errors
-      (save-excursion
-        (dotimes (i company-elisp-parse-depth)
-          (up-list -1)
-          (save-excursion
-            (cond
-             ((looking-at company-elisp-binding-regexp)
-              (down-list 2)
-              (ignore-errors
-                (dotimes (i company-elisp-parse-limit)
-                  (save-excursion
-                    (when (looking-at "[ \t\n]*(")
-                      (down-list 1))
-                    (and (looking-at regexp)
-                         ;; Don't add incomplete text as candidate.
-                         (not (eq (match-end 0) pos))
-                         (add-to-list 'vars (match-string-no-properties 1))))
-                  (forward-sexp))))
-             ((looking-at company-elisp-binding-regexp-1)
-              (down-list 2)
-              (and (looking-at regexp)
-                   ;; Don't add incomplete text as candidate.
-                   (not (eq (match-end 0) pos))
-                   (add-to-list 'vars (match-string-no-properties 1)))))))))
-    vars))
+        (pos (point))
+        res)
+    (condition-case nil
+        (save-excursion
+          (dotimes (_ company-elisp-parse-depth)
+            (up-list -1)
+            (save-excursion
+              (when (eq (char-after) ?\()
+                (forward-char 1)
+                (when (ignore-errors
+                        (save-excursion (forward-list)
+                                        (<= (point) pos)))
+                  (skip-chars-forward " \t\n")
+                  (cond
+                   ((looking-at (if functions-p
+                                    company-elisp-fun-binding-regexp
+                                  company-elisp-var-binding-regexp))
+                    (down-list 1)
+                    (condition-case nil
+                        (dotimes (_ company-elisp-parse-limit)
+                          (save-excursion
+                            (when (looking-at "[ \t\n]*(")
+                              (down-list 1))
+                            (when (looking-at regexp)
+                              (cl-pushnew (match-string-no-properties 1) res)))
+                          (forward-sexp))
+                      (scan-error nil)))
+                   ((unless functions-p
+                      (looking-at company-elisp-var-binding-regexp-1))
+                    (down-list 1)
+                    (when (looking-at regexp)
+                      (cl-pushnew (match-string-no-properties 1) res)))))))))
+      (scan-error nil))
+    res))
 
 (defun company-elisp-candidates (prefix)
+  (let* ((predicate (company-elisp--candidates-predicate prefix))
+         (locals (company-elisp--locals prefix (eq predicate 'fboundp)))
+         (globals (company-elisp--globals prefix predicate))
+         (locals (cl-loop for local in locals
+                          when (not (member local globals))
+                          collect local)))
+    (if company-elisp-show-locals-first
+        (append (sort locals 'string<)
+                (sort globals 'string<))
+      (append locals globals))))
+
+(defun company-elisp--globals (prefix predicate)
+  (all-completions prefix obarray predicate))
+
+(defun company-elisp--candidates-predicate (prefix)
   (let* ((completion-ignore-case nil)
-         (before (char-before (- (point) (length prefix))))
-         (predicate (if (and company-elisp-detect-function-context
-                             (not (eq before ?')))
-                        (if (eq before ?\()
-                            'fboundp
-                          'boundp)
-                      'company-elisp-predicate))
-         (candidates (all-completions prefix obarray predicate)))
-    (company-elisp-parse-local prefix candidates)))
-
-(defun company-elisp-doc (symbol)
+         (beg (- (point) (length prefix)))
+         (before (char-before beg)))
+    (if (and company-elisp-detect-function-context
+             (not (memq before '(?' ?`))))
+        (if (and (eq before ?\()
+                 (not
+                  (save-excursion
+                    (ignore-errors
+                      (goto-char (1- beg))
+                      (or (company-elisp--before-binding-varlist-p)
+                          (progn
+                            (up-list -1)
+                            (company-elisp--before-binding-varlist-p)))))))
+            'fboundp
+          'boundp)
+      'company-elisp--predicate)))
+
+(defun company-elisp--before-binding-varlist-p ()
+  (save-excursion
+    (and (prog1 (search-backward "(")
+           (forward-char 1))
+         (looking-at company-elisp-var-binding-regexp))))
+
+(defun company-elisp--doc (symbol)
   (let* ((symbol (intern symbol))
          (doc (if (fboundp symbol)
                   (documentation symbol t)
@@ -114,23 +193,33 @@ Functions are offered for completion only after ' and \(."
 
 ;;;###autoload
 (defun company-elisp (command &optional arg &rest ignored)
-  "A `company-mode' completion back-end for `emacs-lisp-mode'."
+  "`company-mode' completion back-end for Emacs Lisp."
   (interactive (list 'interactive))
-  (case command
+  (cl-case command
     (interactive (company-begin-backend 'company-elisp))
-    (prefix (and (eq (derived-mode-p 'emacs-lisp-mode) 'emacs-lisp-mode)
-                 (company-grab-lisp-symbol)))
+    (prefix (and (derived-mode-p 'emacs-lisp-mode 'inferior-emacs-lisp-mode)
+                 (company-elisp--prefix)))
     (candidates (company-elisp-candidates arg))
-    (meta (company-elisp-doc arg))
+    (sorted company-elisp-show-locals-first)
+    (meta (company-elisp--doc arg))
     (doc-buffer (let ((symbol (intern arg)))
                   (save-window-excursion
-                    (when (or (ignore-errors (describe-function symbol))
-                              (ignore-errors (describe-variable symbol)))
+                    (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)))))
     (location (let ((sym (intern arg)))
-                (or (ignore-errors (find-definition-noselect sym nil))
-                    (ignore-errors (find-definition-noselect sym 'defvar))
-                    (ignore-errors (find-definition-noselect sym t)))))))
+                (cond
+                 ((fboundp sym) (find-definition-noselect sym nil))
+                 ((boundp sym) (find-definition-noselect sym 'defvar))
+                 ((featurep sym) (cons (find-file-noselect (find-library-name
+                                                            (symbol-name sym)))
+                                       0))
+                 ((facep sym) (find-definition-noselect sym 'defface)))))))
 
 (provide 'company-elisp)
 ;;; company-elisp.el ends here