company-capf.el

   1 ;;; company-capf.el --- company-mode completion-at-point-functions back-end -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2013-2014  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 'cl-lib)
  29
  30 (defvar company--capf-data nil)
  31 (make-variable-buffer-local 'company--capf-data)
  32
  33 (defun company--capf-clear-data (&optional _ignore)
  34   (setq company--capf-data nil)
  35   (remove-hook 'company-completion-cancelled-hook 'company--capf-clear-data t)
  36   (remove-hook 'company-completion-finished-hook 'company--capf-clear-data t))
  37
  38 (defun company--capf-data ()
  39   ;; Ignore tags-completion-at-point-function because it subverts company-etags
  40   ;; in the default value of company-backends, where the latter comes later.
  41   (cl-letf* (((default-value 'completion-at-point-functions) nil)
  42              (data (run-hook-wrapped 'completion-at-point-functions
  43                                      ;; Ignore misbehaving functions.
  44                                      #'completion--capf-wrapper 'optimist)))
  45     (when (and (consp (cdr data)) (numberp (nth 1 data))) data)))
  46
  47 (defun company-capf (command &optional arg &rest _args)
  48   "`company-mode' back-end using `completion-at-point-functions'."
  49   (interactive (list 'interactive))
  50   (pcase command
  51     (`interactive (company-begin-backend 'company-capf))
  52     (`prefix
  53      (let ((res (company--capf-data)))
  54        (when res
  55          (if (> (nth 2 res) (point))
  56              'stop
  57            (setq company--capf-data res)
  58            (add-hook 'company-completion-cancelled-hook 'company--capf-clear-data nil t)
  59            (add-hook 'company-completion-finished-hook 'company--capf-clear-data nil t)
  60            (buffer-substring-no-properties (nth 1 res) (point))))))
  61     (`candidates
  62      (let ((res company--capf-data))
  63        (when res
  64          (let* ((table (nth 3 res))
  65                 (pred (plist-get (nthcdr 4 res) :predicate))
  66                 (meta (completion-metadata
  67                       (buffer-substring (nth 1 res) (nth 2 res))
  68                       table pred))
  69                 (sortfun (cdr (assq 'display-sort-function meta)))
  70                 (candidates (completion-all-completions arg table pred (length arg)))
  71                 (last (last candidates))
  72                 (base-size (and (numberp (cdr last)) (cdr last))))
  73            (when base-size
  74              (setcdr last nil))
  75            (when sortfun
  76              (setq candidates (funcall sortfun candidates)))
  77            (if (not (zerop (or base-size 0)))
  78                (let ((before (substring arg 0 base-size)))
  79                  (mapcar (lambda (candidate)
  80                            (concat before candidate))
  81                          candidates))
  82              candidates)))))
  83     (`sorted
  84      (let ((res company--capf-data))
  85        (when res
  86          (let ((meta (completion-metadata
  87                       (buffer-substring (nth 1 res) (nth 2 res))
  88                       (nth 3 res) (plist-get (nthcdr 4 res) :predicate))))
  89            (cdr (assq 'display-sort-function meta))))))
  90     (`match
  91      ;; Can't just use 0 when base-size (see above) is non-zero.
  92      (let ((start (if (get-text-property 0 'font-lock-face arg)
  93                       0
  94                     (next-single-property-change 0 'font-lock-face arg))))
  95        (when start
  96          ;; completions-common-part comes first, but we can't just look for this
  97          ;; value because it can be in a list.
  98          (or
  99           (let ((value (get-text-property start 'font-lock-face arg)))
 100             (text-property-not-all start (length arg)
 101                                    'font-lock-face value arg))
 102           (length arg)))))
 103     (`duplicates t)
 104     (`no-cache t)   ;Not much can be done here, as long as we handle
 105                     ;non-prefix matches.
 106     (`meta
 107      (let ((f (plist-get (nthcdr 4 company--capf-data) :company-docsig)))
 108        (when f (funcall f arg))))
 109     (`doc-buffer
 110      (let ((f (plist-get (nthcdr 4 company--capf-data) :company-doc-buffer)))
 111        (when f (funcall f arg))))
 112     (`location
 113      (let ((f (plist-get (nthcdr 4 company--capf-data) :company-location)))
 114        (when f (funcall f arg))))
 115     (`annotation
 116      (save-excursion
 117        ;; FIXME: `company-begin' sets `company-point' after calling
 118        ;; `company--begin-new'.  We shouldn't rely on `company-point' here,
 119        ;; better to cache the capf-data value instead.
 120        (when company-point
 121          (goto-char company-point))
 122        (let ((f (plist-get (nthcdr 4 company--capf-data) :annotation-function)))
 123          (when f (funcall f arg)))))
 124     (`require-match
 125      (plist-get (nthcdr 4 company--capf-data) :company-require-match))
 126     (`init nil)      ;Don't bother: plenty of other ways to initialize the code.
 127     (`post-completion
 128      (let* ((res company--capf-data)
 129             (exit-function (plist-get (nthcdr 4 res) :exit-function)))
 130        (if exit-function
 131            (funcall exit-function arg 'finished))))
 132     ))
 133
 134 (provide 'company-capf)
 135
 136 ;;; company-capf.el ends here