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

   1 ;;; company-clang.el --- company-mode completion backend for Clang  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2009, 2011, 2013-2016  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 (require 'company-template)
  30 (require 'cl-lib)
  31
  32 (defgroup company-clang nil
  33   "Completion backend for Clang."
  34   :group 'company)
  35
  36 (defcustom company-clang-executable
  37   (executable-find "clang")
  38   "Location of clang executable."
  39   :type 'file)
  40
  41 (defcustom company-clang-begin-after-member-access t
  42   "When non-nil, automatic completion will start whenever the current
  43 symbol is preceded by \".\", \"->\" or \"::\", ignoring
  44 `company-minimum-prefix-length'.
  45
  46 If `company-begin-commands' is a list, it should include `c-electric-lt-gt'
  47 and `c-electric-colon', for automatic completion right after \">\" and
  48 \":\".")
  49
  50 (defcustom company-clang-arguments nil
  51   "Additional arguments to pass to clang when completing.
  52 Prefix files (-include ...) can be selected with `company-clang-set-prefix'
  53 or automatically through a custom `company-clang-prefix-guesser'."
  54   :type '(repeat (string :tag "Argument")))
  55
  56 (defcustom company-clang-prefix-guesser 'company-clang-guess-prefix
  57   "A function to determine the prefix file for the current buffer."
  58   :type '(function :tag "Guesser function" nil))
  59
  60 (defvar company-clang-modes '(c-mode c++-mode objc-mode)
  61   "Major modes which clang may complete.")
  62
  63 (defcustom company-clang-insert-arguments t
  64   "When non-nil, insert function arguments as a template after completion."
  65   :type 'boolean
  66   :package-version '(company . "0.8.0"))
  67
  68 ;; prefix ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69
  70 (defvar company-clang--prefix nil)
  71
  72 (defsubst company-clang--guess-pch-file (file)
  73   (let ((dir (directory-file-name (file-name-directory file))))
  74     (when (equal (file-name-nondirectory dir) "Classes")
  75       (setq dir (file-name-directory dir)))
  76     (car (directory-files dir t "\\([^.]h\\|[^h]\\).pch\\'" t))))
  77
  78 (defsubst company-clang--file-substring (file beg end)
  79   (with-temp-buffer
  80     (insert-file-contents-literally file nil beg end)
  81     (buffer-string)))
  82
  83 (defun company-clang-guess-prefix ()
  84   "Try to guess the prefix file for the current buffer."
  85   ;; Prefixes seem to be called .pch.  Pre-compiled headers do, too.
  86   ;; So we look at the magic number to rule them out.
  87   (let* ((file (company-clang--guess-pch-file buffer-file-name))
  88          (magic-number (and file (company-clang--file-substring file 0 4))))
  89     (unless (member magic-number '("CPCH" "gpch"))
  90       file)))
  91
  92 (defun company-clang-set-prefix (&optional prefix)
  93   "Use PREFIX as a prefix (-include ...) file for clang completion."
  94   (interactive (let ((def (funcall company-clang-prefix-guesser)))
  95      (unless (stringp def)
  96        (setq def default-directory))
  97      (list (read-file-name "Prefix file: "
  98                            (when def (file-name-directory def))
  99                            def t (when def (file-name-nondirectory def))))))
 100   ;; TODO: pre-compile?
 101   (setq company-clang--prefix (and (stringp prefix)
 102                                    (file-regular-p prefix)
 103                                    prefix)))
 104
 105 ;; Clean-up on exit.
 106 (add-hook 'kill-emacs-hook 'company-clang-set-prefix)
 107
 108 ;; parsing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 109
 110 ;; TODO: Handle Pattern (syntactic hints would be neat).
 111 ;; Do we ever see OVERLOAD (or OVERRIDE)?
 112 (defconst company-clang--completion-pattern
 113   "^COMPLETION: \\_<\\(%s[a-zA-Z0-9_:]*\\)\\(?: : \\(.*\\)$\\)?$")
 114
 115 (defconst company-clang--error-buffer-name "*clang-error*")
 116
 117 (defun company-clang--lang-option ()
 118      (if (eq major-mode 'objc-mode)
 119          (if (string= "m" (file-name-extension buffer-file-name))
 120              "objective-c" "objective-c++")
 121        (substring (symbol-name major-mode) 0 -5)))
 122
 123 (defun company-clang--parse-output (prefix _objc)
 124   (goto-char (point-min))
 125   (let ((pattern (format company-clang--completion-pattern
 126                          (regexp-quote prefix)))
 127         (case-fold-search nil)
 128         lines match)
 129     (while (re-search-forward pattern nil t)
 130       (setq match (match-string-no-properties 1))
 131       (unless (equal match "Pattern")
 132         (save-match-data
 133           (when (string-match ":" match)
 134             (setq match (substring match 0 (match-beginning 0)))))
 135         (let ((meta (match-string-no-properties 2)))
 136           (when (and meta (not (string= match meta)))
 137             (put-text-property 0 1 'meta
 138                                (company-clang--strip-formatting meta)
 139                                match)))
 140         (push match lines)))
 141     lines))
 142
 143 (defun company-clang--meta (candidate)
 144   (get-text-property 0 'meta candidate))
 145
 146 (defun company-clang--annotation (candidate)
 147   (let ((ann (company-clang--annotation-1 candidate)))
 148     (if (not (and ann (string-prefix-p "(*)" ann)))
 149         ann
 150       (with-temp-buffer
 151         (insert ann)
 152         (search-backward ")")
 153         (let ((pt (1+ (point))))
 154           (re-search-forward ".\\_>" nil t)
 155           (delete-region pt (point)))
 156         (buffer-string)))))
 157
 158 (defun company-clang--annotation-1 (candidate)
 159   (let ((meta (company-clang--meta candidate)))
 160     (cond
 161      ((null meta) nil)
 162      ((string-match "[^:]:[^:]" meta)
 163       (substring meta (1+ (match-beginning 0))))
 164      ((string-match "\\((.*)[ a-z]*\\'\\)" meta)
 165       (let ((paren (match-beginning 1)))
 166         (if (not (eq (aref meta (1- paren)) ?>))
 167             (match-string 1 meta)
 168           (with-temp-buffer
 169             (insert meta)
 170             (goto-char paren)
 171             (substring meta (1- (search-backward "<"))))))))))
 172
 173 (defun company-clang--strip-formatting (text)
 174   (replace-regexp-in-string
 175    "#]" " "
 176    (replace-regexp-in-string "[<{[]#\\|#[>}]" "" text t)
 177    t))
 178
 179 (defun company-clang--handle-error (res args)
 180   (goto-char (point-min))
 181   (let* ((buf (get-buffer-create company-clang--error-buffer-name))
 182          (cmd (concat company-clang-executable " " (mapconcat 'identity args " ")))
 183          (pattern (format company-clang--completion-pattern ""))
 184          (err (if (re-search-forward pattern nil t)
 185                   (buffer-substring-no-properties (point-min)
 186                                                   (1- (match-beginning 0)))
 187                 ;; Warn the user more aggressively if no match was found.
 188                 (message "clang failed with error %d:\n%s" res cmd)
 189                 (buffer-string))))
 190
 191     (with-current-buffer buf
 192       (let ((inhibit-read-only t))
 193         (erase-buffer)
 194         (insert (current-time-string)
 195                 (format "\nclang failed with error %d:\n" res)
 196                 cmd "\n\n")
 197         (insert err)
 198         (setq buffer-read-only t)
 199         (goto-char (point-min))))))
 200
 201 (defun company-clang--start-process (prefix callback &rest args)
 202   (let ((objc (derived-mode-p 'objc-mode))
 203         (buf (get-buffer-create "*clang-output*"))
 204         ;; Looks unnecessary in Emacs 25.1 and later.
 205         (process-adaptive-read-buffering nil))
 206     (if (get-buffer-process buf)
 207         (funcall callback nil)
 208       (with-current-buffer buf
 209         (erase-buffer)
 210         (setq buffer-undo-list t))
 211       (let ((process (apply #'start-process "company-clang" buf
 212                             company-clang-executable args)))
 213         (set-process-sentinel
 214          process
 215          (lambda (proc status)
 216            (unless (string-match-p "hangup" status)
 217              (funcall
 218               callback
 219               (let ((res (process-exit-status proc)))
 220                 (with-current-buffer buf
 221                   (unless (eq 0 res)
 222                     (company-clang--handle-error res args))
 223                   ;; Still try to get any useful input.
 224                   (company-clang--parse-output prefix objc)))))))
 225         (unless (company-clang--auto-save-p)
 226           (send-region process (point-min) (point-max))
 227           (send-string process "\n")
 228           (process-send-eof process))))))
 229
 230 (defsubst company-clang--build-location (pos)
 231   (save-excursion
 232     (goto-char pos)
 233     (format "%s:%d:%d"
 234             (if (company-clang--auto-save-p) buffer-file-name "-")
 235             (line-number-at-pos)
 236             (1+ (length
 237                  (encode-coding-region
 238                   (line-beginning-position)
 239                   (point)
 240                   'utf-8
 241                   t))))))
 242
 243 (defsubst company-clang--build-complete-args (pos)
 244   (append '("-fsyntax-only" "-Xclang" "-code-completion-macros")
 245           (unless (company-clang--auto-save-p)
 246             (list "-x" (company-clang--lang-option)))
 247           company-clang-arguments
 248           (when (stringp company-clang--prefix)
 249             (list "-include" (expand-file-name company-clang--prefix)))
 250           (list "-Xclang" (format "-code-completion-at=%s"
 251                                   (company-clang--build-location pos)))
 252           (list (if (company-clang--auto-save-p) buffer-file-name "-"))))
 253
 254 (defun company-clang--candidates (prefix callback)
 255   (and (company-clang--auto-save-p)
 256        (buffer-modified-p)
 257        (basic-save-buffer))
 258   (when (null company-clang--prefix)
 259     (company-clang-set-prefix (or (funcall company-clang-prefix-guesser)
 260                                   'none)))
 261   (apply 'company-clang--start-process
 262          prefix
 263          callback
 264          (company-clang--build-complete-args (- (point) (length prefix)))))
 265
 266 (defun company-clang--prefix ()
 267   (if company-clang-begin-after-member-access
 268       (company-grab-symbol-cons "\\.\\|->\\|::" 2)
 269     (company-grab-symbol)))
 270
 271 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 272
 273 (defconst company-clang-required-version 1.1)
 274
 275 (defvar company-clang--version nil)
 276
 277 (defun company-clang--auto-save-p ()
 278   (< company-clang--version 2.9))
 279
 280 (defsubst company-clang-version ()
 281   "Return the version of `company-clang-executable'."
 282   (with-temp-buffer
 283     (call-process company-clang-executable nil t nil "--version")
 284     (goto-char (point-min))
 285     (if (re-search-forward "clang\\(?: version \\|-\\)\\([0-9.]+\\)" nil t)
 286         (let ((ver (string-to-number (match-string-no-properties 1))))
 287           (if (> ver 100)
 288               (/ ver 100)
 289             ver))
 290       0)))
 291
 292 (defun company-clang (command &optional arg &rest ignored)
 293   "`company-mode' completion backend for Clang.
 294 Clang is a parser for C and ObjC.  Clang version 1.1 or newer is required.
 295
 296 Additional command line arguments can be specified in
 297 `company-clang-arguments'.  Prefix files (-include ...) can be selected
 298 with `company-clang-set-prefix' or automatically through a custom
 299 `company-clang-prefix-guesser'.
 300
 301 With Clang versions before 2.9, we have to save the buffer before
 302 performing completion.  With Clang 2.9 and later, buffer contents are
 303 passed via standard input."
 304   (interactive (list 'interactive))
 305   (cl-case command
 306     (interactive (company-begin-backend 'company-clang))
 307     (init (when (memq major-mode company-clang-modes)
 308             (unless company-clang-executable
 309               (error "Company found no clang executable"))
 310             (setq company-clang--version (company-clang-version))
 311             (when (< company-clang--version company-clang-required-version)
 312               (error "Company requires clang version 1.1"))))
 313     (prefix (and (memq major-mode company-clang-modes)
 314                  buffer-file-name
 315                  company-clang-executable
 316                  (not (company-in-string-or-comment))
 317                  (or (company-clang--prefix) 'stop)))
 318     (candidates (cons :async
 319                       (lambda (cb) (company-clang--candidates arg cb))))
 320     (meta       (company-clang--meta arg))
 321     (annotation (company-clang--annotation arg))
 322     (post-completion (let ((anno (company-clang--annotation arg)))
 323                        (when (and company-clang-insert-arguments anno)
 324                          (insert anno)
 325                          (if (string-match "\\`:[^:]" anno)
 326                              (company-template-objc-templatify anno)
 327                            (company-template-c-like-templatify
 328                             (concat arg anno))))))))
 329
 330 (provide 'company-clang)
 331 ;;; company-clang.el ends here