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