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
  44 (defun company-grab-lisp-symbol ()
  45   (let ((prefix (company-grab-symbol)))
  46     (if prefix
  47         (unless (and (company-in-string-or-comment)
  48                      (/= (char-before (- (point) (length prefix))) ?`))
  49           prefix)
  50       'stop)))
  51
  52 (defun company-elisp-predicate (symbol)
  53   (or (boundp symbol)
  54       (fboundp symbol)
  55       (facep symbol)
  56       (featurep symbol)))
  57
  58 (defvar company-elisp-parse-limit 30)
  59 (defvar company-elisp-parse-depth 100)
  60
  61 (defvar company-elisp-var-binding-regexp
  62   (concat "\\_<" (regexp-opt '("let" "defun" "defmacro" "defsubst"
  63                                "lambda" "lexical-let"))
  64           "\\*?\\_>")
  65   "Regular expression matching head of a multiple variable bindings form.")
  66
  67 (defvar company-elisp-var-binding-regexp-1
  68   (concat "\\_<\\(?:cl-\\)?" (regexp-opt '("dolist" "dotimes")) "\\_>")
  69   "Regular expression matching head of a form with one variable binding.")
  70
  71 (defvar company-elisp-fun-binding-regexp
  72   (concat "\\_<\\(?:cl-\\)?" (regexp-opt '("flet" "labels")) "\\_>")
  73   "Regular expression matching head of a function bindings form.")
  74
  75 (defun company-elisp-locals (prefix functions-p)
  76   (let ((regexp (concat "[ \t\n]*\\(\\_<" (regexp-quote prefix)
  77                         "\\(?:\\sw\\|\\s_\\)*\\_>\\)"))
  78         (pos (point))
  79         res)
  80     (condition-case nil
  81         (save-excursion
  82           (dotimes (i company-elisp-parse-depth)
  83             (up-list -1)
  84             (save-excursion
  85               (when (eq (char-after) ?\()
  86                 (forward-char 1)
  87                 (when (ignore-errors
  88                         (save-excursion (forward-list)
  89                                         (<= (point) pos)))
  90                   (skip-chars-forward " \t\n")
  91                   (cond
  92                    ((looking-at (if functions-p
  93                                     company-elisp-fun-binding-regexp
  94                                   company-elisp-var-binding-regexp))
  95                     (down-list 1)
  96                     (condition-case nil
  97                         (dotimes (i company-elisp-parse-limit)
  98                           (save-excursion
  99                             (when (looking-at "[ \t\n]*(")
 100                               (down-list 1))
 101                             (when (looking-at regexp)
 102                               (pushnew (match-string-no-properties 1) res)))
 103                           (forward-sexp))
 104                       (scan-error nil)))
 105                    ((unless functions-p
 106                       (looking-at company-elisp-var-binding-regexp-1))
 107                     (down-list 1)
 108                     (when (looking-at regexp)
 109                       (pushnew (match-string-no-properties 1) res)))))))))
 110       (scan-error nil))
 111     res))
 112
 113 (defun company-elisp-candidates (prefix)
 114   (let* ((predicate (company-elisp-candidates-predicate prefix))
 115          (locals (company-elisp-locals prefix (eq predicate 'fboundp)))
 116          (globals (company-elisp-globals prefix predicate))
 117          (locals (loop for local in locals
 118                        when (not (member local globals))
 119                        collect local)))
 120     (if company-elisp-show-locals-first
 121         (append (sort locals 'string<)
 122                 (sort globals 'string<))
 123       (append locals globals))))
 124
 125 (defun company-elisp-globals (prefix predicate)
 126   (all-completions prefix obarray predicate))
 127
 128 (defun company-elisp-candidates-predicate (prefix)
 129   (let* ((completion-ignore-case nil)
 130          (before (char-before (- (point) (length prefix)))))
 131     (if (and company-elisp-detect-function-context
 132              (not (eq before ?')))
 133         (if (and (eq before ?\()
 134                  (not
 135                   (save-excursion
 136                     (ignore-errors
 137                       (up-list -2)
 138                       (and (save-excursion
 139                              (forward-char 1)
 140                              (looking-at "[ \t\n]*("))
 141                            (prog1 (search-backward "(")
 142                              (forward-char 1))
 143                            (looking-at company-elisp-var-binding-regexp))))))
 144             'fboundp
 145           'boundp)
 146       'company-elisp-predicate)))
 147
 148 (defun company-elisp-doc (symbol)
 149   (let* ((symbol (intern symbol))
 150          (doc (if (fboundp symbol)
 151                   (documentation symbol t)
 152                 (documentation-property symbol 'variable-documentation t))))
 153     (and (stringp doc)
 154          (string-match ".*$" doc)
 155          (match-string 0 doc))))
 156
 157 ;;;###autoload
 158 (defun company-elisp (command &optional arg &rest ignored)
 159   "A `company-mode' completion back-end for `emacs-lisp-mode'."
 160   (interactive (list 'interactive))
 161   (case command
 162     (interactive (company-begin-backend 'company-elisp))
 163     (prefix (and (eq (derived-mode-p 'emacs-lisp-mode) 'emacs-lisp-mode)
 164                  (company-grab-lisp-symbol)))
 165     (candidates (company-elisp-candidates arg))
 166     (sorted company-elisp-show-locals-first)
 167     (meta (company-elisp-doc arg))
 168     (doc-buffer (let ((symbol (intern arg)))
 169                   (save-window-excursion
 170                     (ignore-errors
 171                       (cond
 172                        ((fboundp symbol) (describe-function symbol))
 173                        ((boundp symbol) (describe-variable symbol))
 174                        ((featurep symbol) (describe-package symbol))
 175                        ((facep symbol) (describe-face symbol))
 176                        (t (signal 'user-error nil)))
 177                       (help-buffer)))))
 178     (location (let ((sym (intern arg)))
 179                 (cond
 180                  ((fboundp sym) (find-definition-noselect sym nil))
 181                  ((boundp sym) (find-definition-noselect sym 'defvar))
 182                  ((featurep sym) (cons (find-file-noselect (find-library-name
 183                                                             (symbol-name sym)))
 184                                        0))
 185                  ((facep sym) (find-definition-noselect sym 'defface)))))))
 186
 187 (provide 'company-elisp)
 188 ;;; company-elisp.el ends here