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

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