forked from OSchip/llvm-project
451 lines
19 KiB
EmacsLisp
451 lines
19 KiB
EmacsLisp
;;; clang-include-fixer.el --- Emacs integration of the clang include fixer -*- lexical-binding: t; -*-
|
||
|
||
;; Keywords: tools, c
|
||
;; Package-Requires: ((cl-lib "0.5") (json "1.2") (let-alist "1.0.4"))
|
||
|
||
;;; Commentary:
|
||
|
||
;; This package allows Emacs users to invoke the 'clang-include-fixer' within
|
||
;; Emacs. 'clang-include-fixer' provides an automated way of adding #include
|
||
;; directives for missing symbols in one translation unit, see
|
||
;; <http://clang.llvm.org/extra/include-fixer.html>.
|
||
|
||
;;; Code:
|
||
|
||
(require 'cl-lib)
|
||
(require 'json)
|
||
(require 'let-alist)
|
||
|
||
(defgroup clang-include-fixer nil
|
||
"Clang-based include fixer."
|
||
:group 'tools)
|
||
|
||
(defvar clang-include-fixer-add-include-hook nil
|
||
"A hook that will be called for every added include.
|
||
The first argument is the filename of the include, the second argument is
|
||
non-nil if the include is a system-header.")
|
||
|
||
(defcustom clang-include-fixer-executable
|
||
"clang-include-fixer"
|
||
"Location of the clang-include-fixer executable.
|
||
|
||
A string containing the name or the full path of the executable."
|
||
:group 'clang-include-fixer
|
||
:type '(file :must-match t)
|
||
:risky t)
|
||
|
||
(defcustom clang-include-fixer-input-format
|
||
'yaml
|
||
"Input format for clang-include-fixer.
|
||
This string is passed as -db argument to
|
||
`clang-include-fixer-executable'."
|
||
:group 'clang-include-fixer
|
||
:type '(radio
|
||
(const :tag "Hard-coded mapping" :fixed)
|
||
(const :tag "YAML" yaml)
|
||
(symbol :tag "Other"))
|
||
:risky t)
|
||
|
||
(defcustom clang-include-fixer-init-string
|
||
""
|
||
"Database initialization string for clang-include-fixer.
|
||
This string is passed as -input argument to
|
||
`clang-include-fixer-executable'."
|
||
:group 'clang-include-fixer
|
||
:type 'string
|
||
:risky t)
|
||
|
||
(defface clang-include-fixer-highlight '((t :background "green"))
|
||
"Used for highlighting the symbol for which a header file is being added.")
|
||
|
||
;;;###autoload
|
||
(defun clang-include-fixer ()
|
||
"Invoke the Include Fixer to insert missing C++ headers."
|
||
(interactive)
|
||
(message (concat "Calling the include fixer. "
|
||
"This might take some seconds. Please wait."))
|
||
(clang-include-fixer--start #'clang-include-fixer--add-header
|
||
"-output-headers"))
|
||
|
||
;;;###autoload
|
||
(defun clang-include-fixer-at-point ()
|
||
"Invoke the Clang include fixer for the symbol at point."
|
||
(interactive)
|
||
(let ((symbol (clang-include-fixer--symbol-at-point)))
|
||
(unless symbol
|
||
(user-error "No symbol at current location"))
|
||
(clang-include-fixer-from-symbol symbol)))
|
||
|
||
;;;###autoload
|
||
(defun clang-include-fixer-from-symbol (symbol)
|
||
"Invoke the Clang include fixer for the SYMBOL.
|
||
When called interactively, prompts the user for a symbol."
|
||
(interactive
|
||
(list (read-string "Symbol: " (clang-include-fixer--symbol-at-point))))
|
||
(clang-include-fixer--start #'clang-include-fixer--add-header
|
||
(format "-query-symbol=%s" symbol)))
|
||
|
||
(defun clang-include-fixer--start (callback &rest args)
|
||
"Asynchronously start clang-include-fixer with parameters ARGS.
|
||
The current file name is passed after ARGS as last argument. If
|
||
the call was successful the returned result is stored in a
|
||
temporary buffer, and CALLBACK is called with the temporary
|
||
buffer as only argument."
|
||
(unless buffer-file-name
|
||
(user-error "clang-include-fixer works only in buffers that visit a file"))
|
||
(let ((process (if (fboundp 'make-process)
|
||
;; Prefer using ‘make-process’ if available, because
|
||
;; ‘start-process’ doesn’t allow us to separate the
|
||
;; standard error from the output.
|
||
(clang-include-fixer--make-process callback args)
|
||
(clang-include-fixer--start-process callback args))))
|
||
(save-restriction
|
||
(widen)
|
||
(process-send-region process (point-min) (point-max)))
|
||
(process-send-eof process))
|
||
nil)
|
||
|
||
(defun clang-include-fixer--make-process (callback args)
|
||
"Start a new clang-incude-fixer process using `make-process'.
|
||
CALLBACK is called after the process finishes successfully; it is
|
||
called with a single argument, the buffer where standard output
|
||
has been inserted. ARGS is a list of additional command line
|
||
arguments. Return the new process object."
|
||
(let ((stdin (current-buffer))
|
||
(stdout (generate-new-buffer "*clang-include-fixer output*"))
|
||
(stderr (generate-new-buffer "*clang-include-fixer errors*")))
|
||
(make-process :name "clang-include-fixer"
|
||
:buffer stdout
|
||
:command (clang-include-fixer--command args)
|
||
:coding 'utf-8-unix
|
||
:noquery t
|
||
:connection-type 'pipe
|
||
:sentinel (clang-include-fixer--sentinel stdin stdout stderr
|
||
callback)
|
||
:stderr stderr)))
|
||
|
||
(defun clang-include-fixer--start-process (callback args)
|
||
"Start a new clang-incude-fixer process using `start-process'.
|
||
CALLBACK is called after the process finishes successfully; it is
|
||
called with a single argument, the buffer where standard output
|
||
has been inserted. ARGS is a list of additional command line
|
||
arguments. Return the new process object."
|
||
(let* ((stdin (current-buffer))
|
||
(stdout (generate-new-buffer "*clang-include-fixer output*"))
|
||
(process-connection-type nil)
|
||
(process (apply #'start-process "clang-include-fixer" stdout
|
||
(clang-include-fixer--command args))))
|
||
(set-process-coding-system process 'utf-8-unix 'utf-8-unix)
|
||
(set-process-query-on-exit-flag process nil)
|
||
(set-process-sentinel process
|
||
(clang-include-fixer--sentinel stdin stdout nil
|
||
callback))
|
||
process))
|
||
|
||
(defun clang-include-fixer--command (args)
|
||
"Return the clang-include-fixer command line.
|
||
Returns a list; the first element is the binary to
|
||
execute (`clang-include-fixer-executable'), and the remaining
|
||
elements are the command line arguments. Adds proper arguments
|
||
for `clang-include-fixer-input-format' and
|
||
`clang-include-fixer-init-string'. Appends the current buffer's
|
||
file name; prepends ARGS directly in front of it."
|
||
(cl-check-type args list)
|
||
`(,clang-include-fixer-executable
|
||
,(format "-db=%s" clang-include-fixer-input-format)
|
||
,(format "-input=%s" clang-include-fixer-init-string)
|
||
"-stdin"
|
||
,@args
|
||
,(buffer-file-name)))
|
||
|
||
(defun clang-include-fixer--sentinel (stdin stdout stderr callback)
|
||
"Return a process sentinel for clang-include-fixer processes.
|
||
STDIN, STDOUT, and STDERR are buffers for the standard streams;
|
||
only STDERR may be nil. CALLBACK is called in the case of
|
||
success; it is called with a single argument, STDOUT. On
|
||
failure, a buffer containing the error output is displayed."
|
||
(cl-check-type stdin buffer-live)
|
||
(cl-check-type stdout buffer-live)
|
||
(cl-check-type stderr (or null buffer-live))
|
||
(cl-check-type callback function)
|
||
(lambda (process event)
|
||
(cl-check-type process process)
|
||
(cl-check-type event string)
|
||
(unwind-protect
|
||
(if (string-equal event "finished\n")
|
||
(progn
|
||
(when stderr (kill-buffer stderr))
|
||
(with-current-buffer stdin
|
||
(funcall callback stdout))
|
||
(kill-buffer stdout))
|
||
(when stderr (kill-buffer stdout))
|
||
(message "clang-include-fixer failed")
|
||
(with-current-buffer (or stderr stdout)
|
||
(insert "\nProcess " (process-name process)
|
||
?\s event))
|
||
(display-buffer (or stderr stdout))))
|
||
nil))
|
||
|
||
(defun clang-include-fixer--replace-buffer (stdout)
|
||
"Replace current buffer by content of STDOUT."
|
||
(cl-check-type stdout buffer-live)
|
||
(barf-if-buffer-read-only)
|
||
(cond ((fboundp 'replace-buffer-contents) (replace-buffer-contents stdout))
|
||
((clang-include-fixer--insert-line stdout (current-buffer)))
|
||
(t (erase-buffer) (insert-buffer-substring stdout)))
|
||
(message "Fix applied")
|
||
nil)
|
||
|
||
(defun clang-include-fixer--insert-line (from to)
|
||
"Insert a single missing line from the buffer FROM into TO.
|
||
FROM and TO must be buffers. If the contents of FROM and TO are
|
||
equal, do nothing and return non-nil. If FROM contains a single
|
||
line missing from TO, insert that line into TO so that the buffer
|
||
contents are equal and return non-nil. Otherwise, do nothing and
|
||
return nil. Buffer restrictions are ignored."
|
||
(cl-check-type from buffer-live)
|
||
(cl-check-type to buffer-live)
|
||
(with-current-buffer from
|
||
(save-excursion
|
||
(save-restriction
|
||
(widen)
|
||
(with-current-buffer to
|
||
(save-excursion
|
||
(save-restriction
|
||
(widen)
|
||
;; Search for the first buffer difference.
|
||
(let ((chars (abs (compare-buffer-substrings to nil nil from nil nil))))
|
||
(if (zerop chars)
|
||
;; Buffer contents are equal, nothing to do.
|
||
t
|
||
(goto-char chars)
|
||
;; We might have ended up in the middle of a line if the
|
||
;; current line partially matches. In this case we would
|
||
;; have to insert more than a line. Move to the beginning of
|
||
;; the line to avoid this situation.
|
||
(beginning-of-line)
|
||
(with-current-buffer from
|
||
(goto-char chars)
|
||
(beginning-of-line)
|
||
(let ((from-begin (point))
|
||
(from-end (progn (forward-line) (point)))
|
||
(to-point (with-current-buffer to (point))))
|
||
;; Search for another buffer difference after the line in
|
||
;; question. If there is none, we can proceed.
|
||
(when (zerop (compare-buffer-substrings from from-end nil
|
||
to to-point nil))
|
||
(with-current-buffer to
|
||
(insert-buffer-substring from from-begin from-end))
|
||
t))))))))))))
|
||
|
||
(defun clang-include-fixer--add-header (stdout)
|
||
"Analyse the result of include-fixer stored in STDOUT.
|
||
Add a missing header if there is any. If there are multiple
|
||
possible headers the user can select one of them to be included.
|
||
Temporarily highlight the affected symbols. Asynchronously call
|
||
clang-include-fixer to insert the selected header."
|
||
(cl-check-type stdout buffer-live)
|
||
(let ((context (clang-include-fixer--parse-json stdout)))
|
||
(let-alist context
|
||
(cond
|
||
((null .QuerySymbolInfos)
|
||
(message "The file is fine, no need to add a header."))
|
||
((null .HeaderInfos)
|
||
(message "Couldn't find header for '%s'"
|
||
(let-alist (car .QuerySymbolInfos) .RawIdentifier)))
|
||
(t
|
||
;; Users may C-g in prompts, make sure the process sentinel
|
||
;; behaves correctly.
|
||
(with-local-quit
|
||
;; Replace the HeaderInfos list by a single header selected by
|
||
;; the user.
|
||
(clang-include-fixer--select-header context)
|
||
;; Call clang-include-fixer again to insert the selected header.
|
||
(clang-include-fixer--start
|
||
(let ((old-tick (buffer-chars-modified-tick)))
|
||
(lambda (stdout)
|
||
(when (/= old-tick (buffer-chars-modified-tick))
|
||
;; Replacing the buffer now would undo the user’s changes.
|
||
(user-error (concat "The buffer has been changed "
|
||
"before the header could be inserted")))
|
||
(clang-include-fixer--replace-buffer stdout)
|
||
(let-alist context
|
||
(let-alist (car .HeaderInfos)
|
||
(with-local-quit
|
||
(run-hook-with-args 'clang-include-fixer-add-include-hook
|
||
(substring .Header 1 -1)
|
||
(string= (substring .Header 0 1) "<")))))))
|
||
(format "-insert-header=%s"
|
||
(clang-include-fixer--encode-json context))))))))
|
||
nil)
|
||
|
||
(defun clang-include-fixer--select-header (context)
|
||
"Prompt the user for a header if necessary.
|
||
CONTEXT must be a clang-include-fixer context object in
|
||
association list format. If it contains more than one HeaderInfo
|
||
element, prompt the user to select one of the headers. CONTEXT
|
||
is modified to include only the selected element."
|
||
(cl-check-type context cons)
|
||
(let-alist context
|
||
(if (cdr .HeaderInfos)
|
||
(clang-include-fixer--prompt-for-header context)
|
||
(message "Only one include is missing: %s"
|
||
(let-alist (car .HeaderInfos) .Header))))
|
||
nil)
|
||
|
||
(defvar clang-include-fixer--history nil
|
||
"History for `clang-include-fixer--prompt-for-header'.")
|
||
|
||
(defun clang-include-fixer--prompt-for-header (context)
|
||
"Prompt the user for a single header.
|
||
The choices are taken from the HeaderInfo elements in CONTEXT.
|
||
They are replaced by the single element selected by the user."
|
||
(let-alist context
|
||
(let ((symbol (clang-include-fixer--symbol-name .QuerySymbolInfos))
|
||
;; Add temporary highlighting so that the user knows which
|
||
;; symbols the current session is about.
|
||
(overlays (remove nil
|
||
(mapcar #'clang-include-fixer--highlight .QuerySymbolInfos))))
|
||
(unwind-protect
|
||
(save-excursion
|
||
;; While prompting, go to the closest overlay so that the user sees
|
||
;; some context.
|
||
(when overlays
|
||
(goto-char (clang-include-fixer--closest-overlay overlays)))
|
||
(cl-flet ((header (info) (let-alist info .Header)))
|
||
;; The header-infos is already sorted by include-fixer.
|
||
(let* ((headers (mapcar #'header .HeaderInfos))
|
||
(header (completing-read
|
||
(clang-include-fixer--format-message
|
||
"Select include for '%s': " symbol)
|
||
headers nil :require-match nil
|
||
'clang-include-fixer--history
|
||
;; Specify a default to prevent the behavior
|
||
;; described in
|
||
;; https://github.com/DarwinAwardWinner/ido-completing-read-plus#why-does-ret-sometimes-not-select-the-first-completion-on-the-list--why-is-there-an-empty-entry-at-the-beginning-of-the-completion-list--what-happened-to-old-style-default-selection.
|
||
(car headers)))
|
||
(info (cl-find header .HeaderInfos :key #'header :test #'string=)))
|
||
(unless info (user-error "No header selected"))
|
||
(setcar .HeaderInfos info)
|
||
(setcdr .HeaderInfos nil))))
|
||
(mapc #'delete-overlay overlays)))))
|
||
|
||
(defun clang-include-fixer--symbol-name (symbol-infos)
|
||
"Return the unique symbol name in SYMBOL-INFOS.
|
||
Raise a signal if the symbol name is not unique."
|
||
(let ((symbols (delete-dups (mapcar (lambda (info)
|
||
(let-alist info .RawIdentifier))
|
||
symbol-infos))))
|
||
(when (cdr symbols)
|
||
(error "Multiple symbols %s returned" symbols))
|
||
(car symbols)))
|
||
|
||
(defun clang-include-fixer--highlight (symbol-info)
|
||
"Add an overlay to highlight SYMBOL-INFO, if it points to a non-empty range.
|
||
Return the overlay object, or nil."
|
||
(let-alist symbol-info
|
||
(unless (zerop .Range.Length)
|
||
(let ((overlay (make-overlay
|
||
(clang-include-fixer--filepos-to-bufferpos
|
||
.Range.Offset 'approximate)
|
||
(clang-include-fixer--filepos-to-bufferpos
|
||
(+ .Range.Offset .Range.Length) 'approximate))))
|
||
(overlay-put overlay 'face 'clang-include-fixer-highlight)
|
||
overlay))))
|
||
|
||
(defun clang-include-fixer--closest-overlay (overlays)
|
||
"Return the start of the overlay in OVERLAYS that is closest to point."
|
||
(cl-check-type overlays cons)
|
||
(let ((point (point))
|
||
acc)
|
||
(dolist (overlay overlays acc)
|
||
(let ((start (overlay-start overlay)))
|
||
(when (or (null acc) (< (abs (- point start)) (abs (- point acc))))
|
||
(setq acc start))))))
|
||
|
||
(defun clang-include-fixer--parse-json (buffer)
|
||
"Parse a JSON response from clang-include-fixer in BUFFER.
|
||
Return the JSON object as an association list."
|
||
(with-current-buffer buffer
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(let ((json-object-type 'alist)
|
||
(json-array-type 'list)
|
||
(json-key-type 'symbol)
|
||
(json-false :json-false)
|
||
(json-null nil)
|
||
(json-pre-element-read-function nil)
|
||
(json-post-element-read-function nil))
|
||
(json-read)))))
|
||
|
||
(defun clang-include-fixer--encode-json (object)
|
||
"Return the JSON representation of OBJECT as a string."
|
||
(let ((json-encoding-separator ",")
|
||
(json-encoding-default-indentation " ")
|
||
(json-encoding-pretty-print nil)
|
||
(json-encoding-lisp-style-closings nil)
|
||
(json-encoding-object-sort-predicate nil))
|
||
(json-encode object)))
|
||
|
||
(defun clang-include-fixer--symbol-at-point ()
|
||
"Return the qualified symbol at point.
|
||
If there is no symbol at point, return nil."
|
||
;; Let ‘bounds-of-thing-at-point’ to do the hard work and deal with edge
|
||
;; cases.
|
||
(let ((bounds (bounds-of-thing-at-point 'symbol)))
|
||
(when bounds
|
||
(let ((beg (car bounds))
|
||
(end (cdr bounds)))
|
||
(save-excursion
|
||
;; Extend the symbol range to the left. Skip over namespace
|
||
;; delimiters and parent namespace names.
|
||
(goto-char beg)
|
||
(while (and (clang-include-fixer--skip-double-colon-backward)
|
||
(skip-syntax-backward "w_")))
|
||
;; Skip over one more namespace delimiter, for absolute names.
|
||
(clang-include-fixer--skip-double-colon-backward)
|
||
(setq beg (point))
|
||
;; Extend the symbol range to the right. Skip over namespace
|
||
;; delimiters and child namespace names.
|
||
(goto-char end)
|
||
(while (and (clang-include-fixer--skip-double-colon-forward)
|
||
(skip-syntax-forward "w_")))
|
||
(setq end (point)))
|
||
(buffer-substring-no-properties beg end)))))
|
||
|
||
(defun clang-include-fixer--skip-double-colon-forward ()
|
||
"Skip a double colon.
|
||
When the next two characters are '::', skip them and return
|
||
non-nil. Otherwise return nil."
|
||
(let ((end (+ (point) 2)))
|
||
(when (and (<= end (point-max))
|
||
(string-equal (buffer-substring-no-properties (point) end) "::"))
|
||
(goto-char end)
|
||
t)))
|
||
|
||
(defun clang-include-fixer--skip-double-colon-backward ()
|
||
"Skip a double colon.
|
||
When the previous two characters are '::', skip them and return
|
||
non-nil. Otherwise return nil."
|
||
(let ((beg (- (point) 2)))
|
||
(when (and (>= beg (point-min))
|
||
(string-equal (buffer-substring-no-properties beg (point)) "::"))
|
||
(goto-char beg)
|
||
t)))
|
||
|
||
;; ‘filepos-to-bufferpos’ is new in Emacs 25.1. Provide a fallback for older
|
||
;; versions.
|
||
(defalias 'clang-include-fixer--filepos-to-bufferpos
|
||
(if (fboundp 'filepos-to-bufferpos)
|
||
'filepos-to-bufferpos
|
||
(lambda (byte &optional _quality _coding-system)
|
||
(byte-to-position (1+ byte)))))
|
||
|
||
;; ‘format-message’ is new in Emacs 25.1. Provide a fallback for older
|
||
;; versions.
|
||
(defalias 'clang-include-fixer--format-message
|
||
(if (fboundp 'format-message) 'format-message 'format))
|
||
|
||
(provide 'clang-include-fixer)
|
||
;;; clang-include-fixer.el ends here
|