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

   1 ;;; company-capf.el --- company-mode completion-at-point-functions backend -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2013-2016  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   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 (require 'cl-lib)
  30
  31 (defvar company--capf-cache nil)
  32
  33 (defun company--capf-data ()
  34   (let ((cache company--capf-cache))
  35     (if (and (equal (current-buffer) (car cache))
  36              (equal (point) (car (setq cache (cdr cache))))
  37              (equal (buffer-chars-modified-tick) (car (setq cache (cdr cache)))))
  38         (cadr cache)
  39       (let ((data (company--capf-data-real)))
  40         (setq company--capf-cache
  41               (list (current-buffer) (point) (buffer-chars-modified-tick) data))
  42         data))))
  43
  44 (defun company--capf-data-real ()
  45   (cl-letf* (((default-value 'completion-at-point-functions)
  46               ;; Ignore tags-completion-at-point-function because it subverts
  47               ;; company-etags in the default value of company-backends, where
  48               ;; the latter comes later.
  49               (remove 'tags-completion-at-point-function
  50                       (default-value 'completion-at-point-functions)))
  51              (completion-at-point-functions (company--capf-workaround))
  52              (data (run-hook-wrapped 'completion-at-point-functions
  53                                      ;; Ignore misbehaving functions.
  54                                      #'completion--capf-wrapper 'optimist)))
  55     (when (and (consp (cdr data)) (integer-or-marker-p (nth 1 data))) data)))
  56
  57 (declare-function python-shell-get-process "python")
  58
  59 (defun company--capf-workaround ()
  60   ;; For http://debbugs.gnu.org/cgi/bugreport.cgi?bug=18067
  61   (if (or (not (listp completion-at-point-functions))
  62           (not (memq 'python-completion-complete-at-point completion-at-point-functions))
  63           (python-shell-get-process))
  64       completion-at-point-functions
  65     (remq 'python-completion-complete-at-point completion-at-point-functions)))
  66
  67 (defun company-capf (command &optional arg &rest _args)
  68   "`company-mode' backend using `completion-at-point-functions'."
  69   (interactive (list 'interactive))
  70   (pcase command
  71     (`interactive (company-begin-backend 'company-capf))
  72     (`prefix
  73      (let ((res (company--capf-data)))
  74        (when res
  75          (let* ((f (plist-get (nthcdr 4 res) :company-prefix-length))
  76                 (beg (nth 1 res))
  77                 (end (nth 2 res))
  78                 (length (and f (funcall f beg (point))))
  79                 (prefix (buffer-substring-no-properties beg (point))))
  80            (cond
  81             ((> end (point)) 'stop)
  82             (length (cons prefix length))
  83             (t prefix))))))
  84     (`candidates
  85      (let ((res (company--capf-data)))
  86        (when res
  87          (let* ((table (nth 3 res))
  88                 (pred (plist-get (nthcdr 4 res) :predicate))
  89                 (meta (completion-metadata
  90                       (buffer-substring (nth 1 res) (nth 2 res))
  91                       table pred))
  92                 (sortfun (cdr (assq 'display-sort-function meta)))
  93                 (candidates (completion-all-completions arg table pred (length arg)))
  94                 (last (last candidates))
  95                 (base-size (and (numberp (cdr last)) (cdr last))))
  96            (when base-size
  97              (setcdr last nil))
  98            (when sortfun
  99              (setq candidates (funcall sortfun candidates)))
 100            (if (not (zerop (or base-size 0)))
 101                (let ((before (substring arg 0 base-size)))
 102                  (mapcar (lambda (candidate)
 103                            (concat before candidate))
 104                          candidates))
 105              candidates)))))
 106     (`sorted
 107      (let ((res (company--capf-data)))
 108        (when res
 109          (let ((meta (completion-metadata
 110                       (buffer-substring (nth 1 res) (nth 2 res))
 111                       (nth 3 res) (plist-get (nthcdr 4 res) :predicate))))
 112            (cdr (assq 'display-sort-function meta))))))
 113     (`match
 114      ;; Can't just use 0 when base-size (see above) is non-zero.
 115      (let ((start (if (get-text-property 0 'font-lock-face arg)
 116                       0
 117                     (next-single-property-change 0 'font-lock-face arg))))
 118        (when start
 119          ;; completions-common-part comes first, but we can't just look for this
 120          ;; value because it can be in a list.
 121          (or
 122           (let ((value (get-text-property start 'font-lock-face arg)))
 123             (text-property-not-all start (length arg)
 124                                    'font-lock-face value arg))
 125           (length arg)))))
 126     (`duplicates t)
 127     (`no-cache t)   ;Not much can be done here, as long as we handle
 128                     ;non-prefix matches.
 129     (`meta
 130      (let ((f (plist-get (nthcdr 4 (company--capf-data)) :company-docsig)))
 131        (when f (funcall f arg))))
 132     (`doc-buffer
 133      (let ((f (plist-get (nthcdr 4 (company--capf-data)) :company-doc-buffer)))
 134        (when f (funcall f arg))))
 135     (`location
 136      (let ((f (plist-get (nthcdr 4 (company--capf-data)) :company-location)))
 137        (when f (funcall f arg))))
 138     (`annotation
 139      (save-excursion
 140        ;; FIXME: `company-begin' sets `company-point' after calling
 141        ;; `company--begin-new'.  We shouldn't rely on `company-point' here,
 142        ;; better to cache the capf-data value instead.  However: we can't just
 143        ;; save the last capf-data value in `prefix', because that command can
 144        ;; get called more often than `candidates', and at any point in the
 145        ;; buffer (https://github.com/company-mode/company-mode/issues/153).
 146        ;; We could try propertizing the returned prefix string, but it's not
 147        ;; passed to `annotation', and `company-prefix' is set only after
 148        ;; `company--strip-duplicates' is called.
 149        (when company-point
 150          (goto-char company-point))
 151        (let ((f (plist-get (nthcdr 4 (company--capf-data)) :annotation-function)))
 152          (when f (funcall f arg)))))
 153     (`require-match
 154      (plist-get (nthcdr 4 (company--capf-data)) :company-require-match))
 155     (`init nil)      ;Don't bother: plenty of other ways to initialize the code.
 156     (`post-completion
 157      (let* ((res (company--capf-data))
 158             (exit-function (plist-get (nthcdr 4 res) :exit-function))
 159             (table (nth 3 res))
 160             (pred (plist-get (nthcdr 4 res) :predicate)))
 161        (if exit-function
 162            ;; Follow the example of `completion--done'.
 163            (funcall exit-function arg
 164                     (if (eq (try-completion arg table pred) t)
 165                         'finished 'sole)))))
 166     ))
 167
 168 (provide 'company-capf)
 169
 170 ;;; company-capf.el ends here