djavu-asus/elpa/company-20230926.32/company-clang.el

   1 ;;; company-clang.el --- company-mode completion backend for Clang  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2009-2011, 2013-2023  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 <https://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, start automatic completion after member access operators.
  43
  44 Automatic completion starts whenever the current symbol is preceded by
  45 \".\", \"->\" or \"::\", ignoring `company-minimum-prefix-length'.
  46
  47 If `company-begin-commands' is a list, it should include `c-electric-lt-gt'
  48 and `c-electric-colon', for automatic completion right after \">\" and
  49 \":\"."
  50   :type 'boolean)
  51
  52 (defcustom company-clang-use-compile-flags-txt nil
  53   "When non-nil, use flags from compile_flags.txt if present.
  54
  55 The lines from that files will be appended to `company-clang-arguments'.
  56
  57 And if such file is found, Clang is called from the directory containing
  58 it.  That allows the flags use relative file names within the project."
  59   :type 'boolean
  60   :safe 'booleanp)
  61
  62 (defcustom company-clang-arguments nil
  63   "A list of additional arguments to pass to clang when completing.
  64 Prefix files (-include ...) can be selected with `company-clang-set-prefix'
  65 or automatically through a custom `company-clang-prefix-guesser'."
  66   :type '(repeat (string :tag "Argument")))
  67
  68 (defcustom company-clang-prefix-guesser 'company-clang-guess-prefix
  69   "A function to determine the prefix file for the current buffer."
  70   :type '(function :tag "Guesser function" nil))
  71
  72 (defvar company-clang-modes '(c-mode c++-mode objc-mode)
  73   "Major modes which clang may complete.")
  74
  75 (defcustom company-clang-insert-arguments t
  76   "When non-nil, insert function arguments as a template after completion."
  77   :type 'boolean
  78   :package-version '(company . "0.8.0"))
  79
  80 ;; prefix ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81
  82 (defvar company-clang--prefix nil)
  83
  84 (defsubst company-clang--guess-pch-file (file)
  85   (let ((dir (directory-file-name (file-name-directory file))))
  86     (when (equal (file-name-nondirectory dir) "Classes")
  87       (setq dir (file-name-directory dir)))
  88     (car (directory-files dir t "\\([^.]h\\|[^h]\\).pch\\'" t))))
  89
  90 (defsubst company-clang--file-substring (file beg end)
  91   (with-temp-buffer
  92     (insert-file-contents-literally file nil beg end)
  93     (buffer-string)))
  94
  95 (defun company-clang-guess-prefix ()
  96   "Try to guess the prefix file for the current buffer."
  97   ;; Prefixes seem to be called .pch.  Pre-compiled headers do, too.
  98   ;; So we look at the magic number to rule them out.
  99   (let* ((file (company-clang--guess-pch-file buffer-file-name))
 100          (magic-number (and file (company-clang--file-substring file 0 4))))
 101     (unless (member magic-number '("CPCH" "gpch"))
 102       file)))
 103
 104 (defun company-clang-set-prefix (&optional prefix)
 105   "Use PREFIX as a prefix (-include ...) file for clang completion."
 106   (interactive (let ((def (funcall company-clang-prefix-guesser)))
 107      (unless (stringp def)
 108        (setq def default-directory))
 109      (list (read-file-name "Prefix file: "
 110                            (when def (file-name-directory def))
 111                            def t (when def (file-name-nondirectory def))))))
 112   ;; TODO: pre-compile?
 113   (setq company-clang--prefix (and (stringp prefix)
 114                                    (file-regular-p prefix)
 115                                    prefix)))
 116
 117 ;; Clean-up on exit.
 118 (add-hook 'kill-emacs-hook 'company-clang-set-prefix)
 119
 120 ;; parsing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 121
 122 ;; Do we ever see OVERLOAD (or OVERRIDE)?
 123 (defconst company-clang--completion-pattern
 124   "^COMPLETION: \\_<\\(%s[a-zA-Z0-9_:]*\\|Pattern\\)\\(?:\\(?: (InBase)\\)? : \\(.*\\)$\\)?$")
 125
 126 (defconst company-clang--error-buffer-name "*clang-error*")
 127
 128 (defun company-clang--lang-option ()
 129      (if (eq major-mode 'objc-mode)
 130          (if (string= "m" (file-name-extension buffer-file-name))
 131              "objective-c" "objective-c++")
 132        (substring (symbol-name major-mode) 0 -5)))
 133
 134 (defun company-clang--parse-output (prefix _objc)
 135   (goto-char (point-min))
 136   (let ((pattern (format company-clang--completion-pattern
 137                          (regexp-quote prefix)))
 138         (case-fold-search nil)
 139         (results (make-hash-table :test 'equal :size (/ (point-max) 100)))
 140         lines)
 141     (while (re-search-forward pattern nil t)
 142       (let ((match (match-string-no-properties 1))
 143             (meta (match-string-no-properties 2)))
 144         (when (equal match "Pattern")
 145           (setq match (company-clang--pattern-to-match meta)))
 146           (when (string-match ":" match)
 147             (setq match (substring match 0 (match-beginning 0))))
 148           ;; Avoiding duplicates:
 149           ;; https://github.com/company-mode/company-mode/issues/841
 150           (cond
 151            ;; Either meta != completion (not a macro)
 152            ((not (equal match meta))
 153             (puthash match meta results))
 154            ;; Or it's the first time we see this completion
 155            ((eq (gethash match results 'none) 'none)
 156             (puthash match nil results)))))
 157     (maphash
 158      (lambda (match meta)
 159        (when meta
 160          (put-text-property 0 1 'meta (company-clang--strip-formatting meta) match))
 161        (push match lines))
 162      results)
 163     lines))
 164
 165 (defun company-clang--pattern-to-match (pat)
 166   (let ((start 0)
 167         (end nil))
 168     (when (string-match "#]" pat)
 169       (setq start (match-end 0)))
 170     (when (string-match "[ \(]<#" pat start)
 171       (setq end (match-beginning 0)))
 172     (substring pat start end)))
 173
 174 (defun company-clang--meta (candidate)
 175   (get-text-property 0 'meta candidate))
 176
 177 (defun company-clang--annotation (candidate)
 178   (let ((ann (company-clang--annotation-1 candidate)))
 179     (if (not (and ann (string-prefix-p "(*)" ann)))
 180         ann
 181       (with-temp-buffer
 182         (insert ann)
 183         (search-backward ")")
 184         (let ((pt (1+ (point))))
 185           (re-search-forward ".\\_>" nil t)
 186           (delete-region pt (point)))
 187         (buffer-string)))))
 188
 189 ;; TODO: Parse the original formatting here, rather than guess.
 190 ;; Strip it every time in the `meta' handler instead.
 191 (defun company-clang--annotation-1 (candidate)
 192   (let ((meta (company-clang--meta candidate)))
 193     (cond
 194      ((null meta) nil)
 195      ((string-match "[^:]:[^:]" meta)
 196       (substring meta (1+ (match-beginning 0))))
 197      ((string-match "(anonymous)" meta) nil)
 198      ((string-match "\\((.*)[ a-z]*\\'\\)" meta)
 199       (let ((paren (match-beginning 1)))
 200         (if (not (eq (aref meta (1- paren)) ?>))
 201             (match-string 1 meta)
 202           (with-temp-buffer
 203             (insert meta)
 204             (goto-char paren)
 205             (substring meta (1- (search-backward "<"))))))))))
 206
 207 (defun company-clang--strip-formatting (text)
 208   (replace-regexp-in-string
 209    "#]" " "
 210    (replace-regexp-in-string "[<{[]#\\|#[>}]" "" text t)
 211    t))
 212
 213 (defun company-clang--handle-error (res args)
 214   (goto-char (point-min))
 215   (let* ((buf (get-buffer-create company-clang--error-buffer-name))
 216          (cmd (concat company-clang-executable " " (mapconcat 'identity args " ")))
 217          (pattern (format company-clang--completion-pattern ""))
 218          (message-truncate-lines t)
 219          (err (if (and (re-search-forward pattern nil t)
 220                        ;; Something in the Windows build?
 221                        ;; Looks like Clang doesn't always include the error text
 222                        ;; before completions (even if exited with error).
 223                        (> (match-beginning 0) (point-min)))
 224                   (buffer-substring-no-properties (point-min)
 225                                                   (1- (match-beginning 0)))
 226                 ;; Warn the user more aggressively if no match was found.
 227                 (message "clang failed with error %d: %s" res cmd)
 228                 (buffer-string))))
 229
 230     (with-current-buffer buf
 231       (let ((inhibit-read-only t))
 232         (erase-buffer)
 233         (insert (current-time-string)
 234                 (format "\nclang failed with error %d:\n" res)
 235                 cmd "\n\n")
 236         (insert err)
 237         (setq buffer-read-only t)
 238         (goto-char (point-min))))))
 239
 240 (defun company-clang--start-process (prefix callback &rest args)
 241   (let* ((objc (derived-mode-p 'objc-mode))
 242          (buf (get-buffer-create "*clang-output*"))
 243          ;; Looks unnecessary in Emacs 25.1 and later.
 244          ;; (Inconclusive, needs more testing):
 245          ;; https://github.com/company-mode/company-mode/pull/288#issuecomment-72491808
 246          (process-adaptive-read-buffering nil)
 247          (existing-process (get-buffer-process buf)))
 248     (when existing-process
 249       (kill-process existing-process))
 250     (with-current-buffer buf
 251       (erase-buffer)
 252       (setq buffer-undo-list t))
 253     (let* ((process-connection-type nil)
 254            (process (apply #'start-file-process "company-clang" buf
 255                            company-clang-executable args)))
 256       (set-process-sentinel
 257        process
 258        (lambda (proc status)
 259          (unless (string-match-p "hangup\\|killed" status)
 260            (funcall
 261             callback
 262             (let ((res (process-exit-status proc)))
 263               (with-current-buffer buf
 264                 (unless (eq 0 res)
 265                   (company-clang--handle-error res args))
 266                 ;; Still try to get any useful input.
 267                 (company-clang--parse-output prefix objc)))))))
 268       (unless (company-clang--auto-save-p)
 269         (send-region process (point-min) (point-max))
 270         (send-string process "\n")
 271         (process-send-eof process)))))
 272
 273 (defsubst company-clang--build-location (pos)
 274   (save-excursion
 275     (goto-char pos)
 276     (format "%s:%d:%d"
 277             (if (company-clang--auto-save-p) buffer-file-name "-")
 278             (line-number-at-pos)
 279             (1+ (length
 280                  (encode-coding-region
 281                   (line-beginning-position)
 282                   (point)
 283                   'utf-8
 284                   t))))))
 285
 286 (defsubst company-clang--build-complete-args (pos)
 287   (append '("-fsyntax-only" "-Xclang" "-code-completion-macros")
 288           (unless (company-clang--auto-save-p)
 289             (list "-x" (company-clang--lang-option)))
 290           (company-clang--arguments)
 291           (when (stringp company-clang--prefix)
 292             (list "-include" (expand-file-name company-clang--prefix)))
 293           (list "-Xclang" (format "-code-completion-at=%s"
 294                                   (company-clang--build-location pos)))
 295           (list (if (company-clang--auto-save-p) buffer-file-name "-"))))
 296
 297 (defun company-clang--arguments ()
 298   (let ((fname "compile_flags.txt")
 299         (args company-clang-arguments)
 300         current-dir-rel)
 301     (when company-clang-use-compile-flags-txt
 302       (let ((dir (locate-dominating-file default-directory fname)))
 303         (when dir
 304           (setq current-dir-rel (file-relative-name default-directory dir))
 305           (setq default-directory dir)
 306           (with-temp-buffer
 307             (insert-file-contents fname)
 308             (setq args
 309                   (append
 310                    args
 311                    (split-string (buffer-substring-no-properties
 312                                   (point-min) (point-max))
 313                                  "[\n\r]+"
 314                                  t
 315                                  "[ \t]+"))))
 316           (unless (equal current-dir-rel "./")
 317             (push (format "-I%s" current-dir-rel) args)))))
 318     args))
 319
 320 (defun company-clang--candidates (prefix callback)
 321   (and (company-clang--auto-save-p)
 322        (buffer-modified-p)
 323        (basic-save-buffer))
 324   (when (null company-clang--prefix)
 325     (company-clang-set-prefix (or (funcall company-clang-prefix-guesser)
 326                                   'none)))
 327   (let ((default-directory default-directory))
 328     (apply 'company-clang--start-process
 329            prefix
 330            callback
 331            (company-clang--build-complete-args
 332             (if (company-clang--check-version 4.0 9.0)
 333                 (point)
 334               (- (point) (length prefix)))))))
 335
 336 (defun company-clang--prefix ()
 337   (if company-clang-begin-after-member-access
 338       (company-grab-symbol-cons "\\.\\|->\\|::" 2)
 339     (company-grab-symbol)))
 340
 341 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 342
 343 (defconst company-clang-required-version 1.1)
 344
 345 (defvar company-clang--version nil)
 346
 347 (defun company-clang--auto-save-p ()
 348   (not
 349    (company-clang--check-version 2.9 3.1)))
 350
 351 (defun company-clang--check-version (min apple-min)
 352   (pcase-exhaustive company-clang--version
 353     (`(apple . ,ver) (>= ver apple-min))
 354     (`(normal . ,ver) (>= ver min))))
 355
 356 (defsubst company-clang-version ()
 357   "Return the version of `company-clang-executable'."
 358   (with-temp-buffer
 359     (call-process company-clang-executable nil t nil "--version")
 360     (goto-char (point-min))
 361     (if (re-search-forward
 362          "\\(clang\\|Apple LLVM\\|bcc32x\\|bcc64\\) version \\([0-9.]+\\)" nil t)
 363         (cons
 364          (if (equal (match-string-no-properties 1) "Apple LLVM")
 365              'apple
 366            'normal)
 367          (string-to-number (match-string-no-properties 2)))
 368       0)))
 369
 370 (defun company-clang (command &optional arg &rest _ignored)
 371   "`company-mode' completion backend for Clang.
 372 Clang is a parser for C and ObjC.  Clang version 1.1 or newer is required.
 373
 374 Additional command line arguments can be specified in
 375 `company-clang-arguments'.  Prefix files (-include ...) can be selected
 376 with `company-clang-set-prefix' or automatically through a custom
 377 `company-clang-prefix-guesser'.
 378
 379 With Clang versions before 2.9, we have to save the buffer before
 380 performing completion.  With Clang 2.9 and later, buffer contents are
 381 passed via standard input."
 382   (interactive (list 'interactive))
 383   (cl-case command
 384     (interactive (company-begin-backend 'company-clang))
 385     (init (when (memq major-mode company-clang-modes)
 386             (unless company-clang-executable
 387               (error "Company found no clang executable"))
 388             (setq company-clang--version (company-clang-version))
 389             (unless (company-clang--check-version
 390                      company-clang-required-version
 391                      company-clang-required-version)
 392               (error "Company requires clang version %s"
 393                      company-clang-required-version))))
 394     (prefix (and (memq major-mode company-clang-modes)
 395                  buffer-file-name
 396                  company-clang-executable
 397                  (not (company-in-string-or-comment))
 398                  (or (company-clang--prefix) 'stop)))
 399     (candidates (cons :async
 400                       (lambda (cb) (company-clang--candidates arg cb))))
 401     (meta       (company-clang--meta arg))
 402     (kind (company-clang--kind arg))
 403     (annotation (company-clang--annotation arg))
 404     (post-completion (let ((anno (company-clang--annotation arg)))
 405                        (when (and company-clang-insert-arguments anno)
 406                          (insert anno)
 407                          (if (string-match "\\`:[^:]" anno)
 408                              (company-template-objc-templatify anno)
 409                            (company-template-c-like-templatify
 410                             (concat arg anno))))))))
 411
 412 (defun company-clang--kind (arg)
 413   ;; XXX: Not very precise.
 414   ;; E.g. it will say that an arg-less ObjC method is a variable (perhaps we
 415   ;; could look around for brackets, etc, if there any actual users who's
 416   ;; bothered by it).
 417   ;; And we can't distinguish between local vars and struct fields.
 418   ;; Or between keywords and macros.
 419   (let ((meta (company-clang--meta arg)))
 420     (cond
 421      ((null meta) 'keyword)
 422      ((string-match "(" meta)
 423       (if (string-match-p (format "\\`%s *\\'" (regexp-quote arg))
 424                           (substring meta 0 (match-beginning 0)))
 425           'keyword ; Also macro, actually (no return type).
 426         'function))
 427      (t 'variable))))
 428
 429 (provide 'company-clang)
 430 ;;; company-clang.el ends here