code.delx.au - gnu-emacs-elpa/blob - company-elisp.el

   1 ;;; company-elisp.el --- A company-mode completion back-end for emacs-lisp-mode -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2009, 2011-2013  Free Software Foundation, Inc.
   4
   5 ;; Author: Nikolaj Schumacher
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22
  23 ;;; Commentary:
  24 ;;
  25
  26 ;;; Code:
  27
  28 (require 'company)
  29 (eval-when-compile (require 'cl))
  30 (require 'help-mode)
  31 (require 'find-func)
  32
  33 (defcustom company-elisp-detect-function-context t
  34   "If enabled, offer Lisp functions only in appropriate contexts.
  35 Functions are offered for completion only after ' and \(."
  36   :group 'company
  37   :type '(choice (const :tag "Off" nil)
  38                  (const :tag "On" t)))
  39
  40 (defcustom company-elisp-show-locals-first t
  41   "If enabled, locally bound variables and functions are displayed
  42 first in the candidates list."
  43   :group 'company
  44   :type '(choice (const :tag "Off" nil)
  45                  (const :tag "On" t)))
  46
  47 (defun company-elisp--prefix ()
  48   (let ((prefix (company-grab-symbol)))
  49     (if prefix
  50         (when (if (company-in-string-or-comment)
  51                   (= (char-before (- (point) (length prefix))) ?`)
  52                 (company-elisp--should-complete))
  53           prefix)
  54       'stop)))
  55
  56 (defun company-elisp--predicate (symbol)
  57   (or (boundp symbol)
  58       (fboundp symbol)
  59       (facep symbol)
  60       (featurep symbol)))
  61
  62 (defun company-elisp--fns-regexp (&rest names)
  63   (concat "\\_<\\(?:cl-\\)?" (regexp-opt names) "\\*?\\_>"))
  64
  65 (defvar company-elisp-parse-limit 30)
  66 (defvar company-elisp-parse-depth 100)
  67
  68 (defvar company-elisp-defun-names '("defun" "defmacro" "defsubst"))
  69
  70 (defvar company-elisp-var-binding-regexp
  71   (apply #'company-elisp--fns-regexp "let" "lambda" "lexical-let"
  72          company-elisp-defun-names)
  73   "Regular expression matching head of a multiple variable bindings form.")
  74
  75 (defvar company-elisp-var-binding-regexp-1
  76   (company-elisp--fns-regexp "dolist" "dotimes")
  77   "Regular expression matching head of a form with one variable binding.")
  78
  79 (defvar company-elisp-fun-binding-regexp
  80   (company-elisp--fns-regexp "flet" "labels")
  81   "Regular expression matching head of a function bindings form.")
  82
  83 (defvar company-elisp-defuns-regexp
  84   (concat "([ \t\n]*"
  85           (apply #'company-elisp--fns-regexp company-elisp-defun-names)))
  86
  87 (defun company-elisp--should-complete ()
  88   (let ((start (point))
  89         (depth (car (syntax-ppss))))
  90     (not
  91      (when (> depth 0)
  92        (save-excursion
  93          (up-list (- depth))
  94          (when (looking-at company-elisp-defuns-regexp)
  95            (forward-char)
  96            (forward-sexp 1)
  97            (unless (= (point) start)
  98              (condition-case nil
  99                  (let ((args-end (scan-sexps (point) 2)))
 100                    (or (null args-end)
 101                        (> args-end start)))
 102                (scan-error
 103                 t)))))))))
 104
 105 (defun company-elisp--locals (prefix functions-p)
 106   (let ((regexp (concat "[ \t\n]*\\(\\_<" (regexp-quote prefix)
 107                         "\\(?:\\sw\\|\\s_\\)*\\_>\\)"))
 108         (pos (point))
 109         res)
 110     (condition-case nil
 111         (save-excursion
 112           (dotimes (i company-elisp-parse-depth)
 113             (up-list -1)
 114             (save-excursion
 115               (when (eq (char-after) ?\()
 116                 (forward-char 1)
 117                 (when (ignore-errors
 118                         (save-excursion (forward-list)
 119                                         (<= (point) pos)))
 120                   (skip-chars-forward " \t\n")
 121                   (cond
 122                    ((looking-at (if functions-p
 123                                     company-elisp-fun-binding-regexp
 124                                   company-elisp-var-binding-regexp))
 125                     (down-list 1)
 126                     (condition-case nil
 127                         (dotimes (i company-elisp-parse-limit)
 128                           (save-excursion
 129                             (when (looking-at "[ \t\n]*(")
 130                               (down-list 1))
 131                             (when (looking-at regexp)
 132                               (pushnew (match-string-no-properties 1) res)))
 133                           (forward-sexp))
 134                       (scan-error nil)))
 135                    ((unless functions-p
 136                       (looking-at company-elisp-var-binding-regexp-1))
 137                     (down-list 1)
 138                     (when (looking-at regexp)
 139                       (pushnew (match-string-no-properties 1) res)))))))))
 140       (scan-error nil))
 141     res))
 142
 143 (defun company-elisp-candidates (prefix)
 144   (let* ((predicate (company-elisp--candidates-predicate prefix))
 145          (locals (company-elisp--locals prefix (eq predicate 'fboundp)))
 146          (globals (company-elisp--globals prefix predicate))
 147          (locals (loop for local in locals
 148                        when (not (member local globals))
 149                        collect local)))
 150     (if company-elisp-show-locals-first
 151         (append (sort locals 'string<)
 152                 (sort globals 'string<))
 153       (append locals globals))))
 154
 155 (defun company-elisp--globals (prefix predicate)
 156   (all-completions prefix obarray predicate))
 157
 158 (defun company-elisp--candidates-predicate (prefix)
 159   (let* ((completion-ignore-case nil)
 160          (before (char-before (- (point) (length prefix)))))
 161     (if (and company-elisp-detect-function-context
 162              (not (eq before ?')))
 163         (if (and (eq before ?\()
 164                  (not
 165                   (save-excursion
 166                     (ignore-errors
 167                       (up-list -2)
 168                       (and (save-excursion
 169                              (forward-char 1)
 170                              (looking-at "[ \t\n]*("))
 171                            (prog1 (search-backward "(")
 172                              (forward-char 1))
 173                            (looking-at company-elisp-var-binding-regexp))))))
 174             'fboundp
 175           'boundp)
 176       'company-elisp--predicate)))
 177
 178 (defun company-elisp--doc (symbol)
 179   (let* ((symbol (intern symbol))
 180          (doc (if (fboundp symbol)
 181                   (documentation symbol t)
 182                 (documentation-property symbol 'variable-documentation t))))
 183     (and (stringp doc)
 184          (string-match ".*$" doc)
 185          (match-string 0 doc))))
 186
 187 ;;;###autoload
 188 (defun company-elisp (command &optional arg &rest ignored)
 189   "A `company-mode' completion back-end for `emacs-lisp-mode'."
 190   (interactive (list 'interactive))
 191   (case command
 192     (interactive (company-begin-backend 'company-elisp))
 193     (prefix (and (eq (derived-mode-p 'emacs-lisp-mode) 'emacs-lisp-mode)
 194                  (company-elisp--prefix)))
 195     (candidates (company-elisp-candidates arg))
 196     (sorted company-elisp-show-locals-first)
 197     (meta (company-elisp--doc arg))
 198     (doc-buffer (let ((symbol (intern arg)))
 199                   (save-window-excursion
 200                     (ignore-errors
 201                       (cond
 202                        ((fboundp symbol) (describe-function symbol))
 203                        ((boundp symbol) (describe-variable symbol))
 204                        ((featurep symbol) (describe-package symbol))
 205                        ((facep symbol) (describe-face symbol))
 206                        (t (signal 'user-error nil)))
 207                       (help-buffer)))))
 208     (location (let ((sym (intern arg)))
 209                 (cond
 210                  ((fboundp sym) (find-definition-noselect sym nil))
 211                  ((boundp sym) (find-definition-noselect sym 'defvar))
 212                  ((featurep sym) (cons (find-file-noselect (find-library-name
 213                                                             (symbol-name sym)))
 214                                        0))
 215                  ((facep sym) (find-definition-noselect sym 'defface)))))))
 216
 217 (provide 'company-elisp)
 218 ;;; company-elisp.el ends here