Mercurial > hg > CbC > CbC_llvm

comparison clang-tools-extra/clang-include-fixer/tool/clang-include-fixer.el @ 150:1d019706d866

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
LLVM10
author anatofuz
date Thu, 13 Feb 2020 15:10:13 +0900
parents
children 1f2b6ac9f198
comparison
equal deleted inserted replaced
147:c2174574ed3a 150:1d019706d866
1 ;;; clang-include-fixer.el --- Emacs integration of the clang include fixer -*- lexical-binding: t; -*-
2
3 ;; Keywords: tools, c
4 ;; Package-Requires: ((cl-lib "0.5") (json "1.2") (let-alist "1.0.4"))
5
6 ;;; Commentary:
7
8 ;; This package allows Emacs users to invoke the 'clang-include-fixer' within
9 ;; Emacs. 'clang-include-fixer' provides an automated way of adding #include
10 ;; directives for missing symbols in one translation unit, see
11 ;; <http://clang.llvm.org/extra/clang-include-fixer.html>.
12
13 ;;; Code:
14
15 (require 'cl-lib)
16 (require 'json)
17 (require 'let-alist)
18
19 (defgroup clang-include-fixer nil
20 "Clang-based include fixer."
21 :group 'tools)
22
23 (defvar clang-include-fixer-add-include-hook nil
24 "A hook that will be called for every added include.
25 The first argument is the filename of the include, the second argument is
26 non-nil if the include is a system-header.")
27
28 (defcustom clang-include-fixer-executable
29 "clang-include-fixer"
30 "Location of the clang-include-fixer executable.
31
32 A string containing the name or the full path of the executable."
33 :group 'clang-include-fixer
34 :type '(file :must-match t)
35 :risky t)
36
37 (defcustom clang-include-fixer-input-format
38 'yaml
39 "Input format for clang-include-fixer.
40 This string is passed as -db argument to
41 `clang-include-fixer-executable'."
42 :group 'clang-include-fixer
43 :type '(radio
44 (const :tag "Hard-coded mapping" :fixed)
45 (const :tag "YAML" yaml)
46 (symbol :tag "Other"))
47 :risky t)
48
49 (defcustom clang-include-fixer-init-string
50 ""
51 "Database initialization string for clang-include-fixer.
52 This string is passed as -input argument to
53 `clang-include-fixer-executable'."
54 :group 'clang-include-fixer
55 :type 'string
56 :risky t)
57
58 (defface clang-include-fixer-highlight '((t :background "green"))
59 "Used for highlighting the symbol for which a header file is being added.")
60
61 ;;;###autoload
62 (defun clang-include-fixer ()
63 "Invoke the Include Fixer to insert missing C++ headers."
64 (interactive)
65 (message (concat "Calling the include fixer. "
66 "This might take some seconds. Please wait."))
67 (clang-include-fixer--start #'clang-include-fixer--add-header
68 "-output-headers"))
69
70 ;;;###autoload
71 (defun clang-include-fixer-at-point ()
72 "Invoke the Clang include fixer for the symbol at point."
73 (interactive)
74 (let ((symbol (clang-include-fixer--symbol-at-point)))
75 (unless symbol
76 (user-error "No symbol at current location"))
77 (clang-include-fixer-from-symbol symbol)))
78
79 ;;;###autoload
80 (defun clang-include-fixer-from-symbol (symbol)
81 "Invoke the Clang include fixer for the SYMBOL.
82 When called interactively, prompts the user for a symbol."
83 (interactive
84 (list (read-string "Symbol: " (clang-include-fixer--symbol-at-point))))
85 (clang-include-fixer--start #'clang-include-fixer--add-header
86 (format "-query-symbol=%s" symbol)))
87
88 (defun clang-include-fixer--start (callback &rest args)
89 "Asynchronously start clang-include-fixer with parameters ARGS.
90 The current file name is passed after ARGS as last argument. If
91 the call was successful the returned result is stored in a
92 temporary buffer, and CALLBACK is called with the temporary
93 buffer as only argument."
94 (unless buffer-file-name
95 (user-error "clang-include-fixer works only in buffers that visit a file"))
96 (let ((process (if (and (fboundp 'make-process)
97 ;; ‘make-process’ doesn’t support remote files
98 ;; (https://debbugs.gnu.org/cgi/bugreport.cgi?bug=28691).
99 (not (find-file-name-handler default-directory
100 'start-file-process)))
101 ;; Prefer using ‘make-process’ if possible, because
102 ;; ‘start-process’ doesn’t allow us to separate the
103 ;; standard error from the output.
104 (clang-include-fixer--make-process callback args)
105 (clang-include-fixer--start-process callback args))))
106 (save-restriction
107 (widen)
108 (process-send-region process (point-min) (point-max)))
109 (process-send-eof process))
110 nil)
111
112 (defun clang-include-fixer--make-process (callback args)
113 "Start a new clang-include-fixer process using `make-process'.
114 CALLBACK is called after the process finishes successfully; it is
115 called with a single argument, the buffer where standard output
116 has been inserted. ARGS is a list of additional command line
117 arguments. Return the new process object."
118 (let ((stdin (current-buffer))
119 (stdout (generate-new-buffer "*clang-include-fixer output*"))
120 (stderr (generate-new-buffer "*clang-include-fixer errors*")))
121 (make-process :name "clang-include-fixer"
122 :buffer stdout
123 :command (clang-include-fixer--command args)
124 :coding 'utf-8-unix
125 :noquery t
126 :connection-type 'pipe
127 :sentinel (clang-include-fixer--sentinel stdin stdout stderr
128 callback)
129 :stderr stderr)))
130
131 (defun clang-include-fixer--start-process (callback args)
132 "Start a new clang-include-fixer process using `start-file-process'.
133 CALLBACK is called after the process finishes successfully; it is
134 called with a single argument, the buffer where standard output
135 has been inserted. ARGS is a list of additional command line
136 arguments. Return the new process object."
137 (let* ((stdin (current-buffer))
138 (stdout (generate-new-buffer "*clang-include-fixer output*"))
139 (process-connection-type nil)
140 (process (apply #'start-file-process "clang-include-fixer" stdout
141 (clang-include-fixer--command args))))
142 (set-process-coding-system process 'utf-8-unix 'utf-8-unix)
143 (set-process-query-on-exit-flag process nil)
144 (set-process-sentinel process
145 (clang-include-fixer--sentinel stdin stdout nil
146 callback))
147 process))
148
149 (defun clang-include-fixer--command (args)
150 "Return the clang-include-fixer command line.
151 Returns a list; the first element is the binary to
152 execute (`clang-include-fixer-executable'), and the remaining
153 elements are the command line arguments. Adds proper arguments
154 for `clang-include-fixer-input-format' and
155 `clang-include-fixer-init-string'. Appends the current buffer's
156 file name; prepends ARGS directly in front of it."
157 (cl-check-type args list)
158 `(,clang-include-fixer-executable
159 ,(format "-db=%s" clang-include-fixer-input-format)
160 ,(format "-input=%s" clang-include-fixer-init-string)
161 "-stdin"
162 ,@args
163 ,(clang-include-fixer--file-local-name buffer-file-name)))
164
165 (defun clang-include-fixer--sentinel (stdin stdout stderr callback)
166 "Return a process sentinel for clang-include-fixer processes.
167 STDIN, STDOUT, and STDERR are buffers for the standard streams;
168 only STDERR may be nil. CALLBACK is called in the case of
169 success; it is called with a single argument, STDOUT. On
170 failure, a buffer containing the error output is displayed."
171 (cl-check-type stdin buffer-live)
172 (cl-check-type stdout buffer-live)
173 (cl-check-type stderr (or null buffer-live))
174 (cl-check-type callback function)
175 (lambda (process event)
176 (cl-check-type process process)
177 (cl-check-type event string)
178 (unwind-protect
179 (if (string-equal event "finished\n")
180 (progn
181 (when stderr (kill-buffer stderr))
182 (with-current-buffer stdin
183 (funcall callback stdout))
184 (kill-buffer stdout))
185 (when stderr (kill-buffer stdout))
186 (message "clang-include-fixer failed")
187 (with-current-buffer (or stderr stdout)
188 (insert "\nProcess " (process-name process)
189 ?\s event))
190 (display-buffer (or stderr stdout))))
191 nil))
192
193 (defun clang-include-fixer--replace-buffer (stdout)
194 "Replace current buffer by content of STDOUT."
195 (cl-check-type stdout buffer-live)
196 (barf-if-buffer-read-only)
197 (cond ((fboundp 'replace-buffer-contents) (replace-buffer-contents stdout))
198 ((clang-include-fixer--insert-line stdout (current-buffer)))
199 (t (erase-buffer) (insert-buffer-substring stdout)))
200 (message "Fix applied")
201 nil)
202
203 (defun clang-include-fixer--insert-line (from to)
204 "Insert a single missing line from the buffer FROM into TO.
205 FROM and TO must be buffers. If the contents of FROM and TO are
206 equal, do nothing and return non-nil. If FROM contains a single
207 line missing from TO, insert that line into TO so that the buffer
208 contents are equal and return non-nil. Otherwise, do nothing and
209 return nil. Buffer restrictions are ignored."
210 (cl-check-type from buffer-live)
211 (cl-check-type to buffer-live)
212 (with-current-buffer from
213 (save-excursion
214 (save-restriction
215 (widen)
216 (with-current-buffer to
217 (save-excursion
218 (save-restriction
219 (widen)
220 ;; Search for the first buffer difference.
221 (let ((chars (abs (compare-buffer-substrings to nil nil from nil nil))))
222 (if (zerop chars)
223 ;; Buffer contents are equal, nothing to do.
224 t
225 (goto-char chars)
226 ;; We might have ended up in the middle of a line if the
227 ;; current line partially matches. In this case we would
228 ;; have to insert more than a line. Move to the beginning of
229 ;; the line to avoid this situation.
230 (beginning-of-line)
231 (with-current-buffer from
232 (goto-char chars)
233 (beginning-of-line)
234 (let ((from-begin (point))
235 (from-end (progn (forward-line) (point)))
236 (to-point (with-current-buffer to (point))))
237 ;; Search for another buffer difference after the line in
238 ;; question. If there is none, we can proceed.
239 (when (zerop (compare-buffer-substrings from from-end nil
240 to to-point nil))
241 (with-current-buffer to
242 (insert-buffer-substring from from-begin from-end))
243 t))))))))))))
244
245 (defun clang-include-fixer--add-header (stdout)
246 "Analyse the result of clang-include-fixer stored in STDOUT.
247 Add a missing header if there is any. If there are multiple
248 possible headers the user can select one of them to be included.
249 Temporarily highlight the affected symbols. Asynchronously call
250 clang-include-fixer to insert the selected header."
251 (cl-check-type stdout buffer-live)
252 (let ((context (clang-include-fixer--parse-json stdout)))
253 (let-alist context
254 (cond
255 ((null .QuerySymbolInfos)
256 (message "The file is fine, no need to add a header."))
257 ((null .HeaderInfos)
258 (message "Couldn't find header for '%s'"
259 (let-alist (car .QuerySymbolInfos) .RawIdentifier)))
260 (t
261 ;; Users may C-g in prompts, make sure the process sentinel
262 ;; behaves correctly.
263 (with-local-quit
264 ;; Replace the HeaderInfos list by a single header selected by
265 ;; the user.
266 (clang-include-fixer--select-header context)
267 ;; Call clang-include-fixer again to insert the selected header.
268 (clang-include-fixer--start
269 (let ((old-tick (buffer-chars-modified-tick)))
270 (lambda (stdout)
271 (when (/= old-tick (buffer-chars-modified-tick))
272 ;; Replacing the buffer now would undo the user’s changes.
273 (user-error (concat "The buffer has been changed "
274 "before the header could be inserted")))
275 (clang-include-fixer--replace-buffer stdout)
276 (let-alist context
277 (let-alist (car .HeaderInfos)
278 (with-local-quit
279 (run-hook-with-args 'clang-include-fixer-add-include-hook
280 (substring .Header 1 -1)
281 (string= (substring .Header 0 1) "<")))))))
282 (format "-insert-header=%s"
283 (clang-include-fixer--encode-json context))))))))
284 nil)
285
286 (defun clang-include-fixer--select-header (context)
287 "Prompt the user for a header if necessary.
288 CONTEXT must be a clang-include-fixer context object in
289 association list format. If it contains more than one HeaderInfo
290 element, prompt the user to select one of the headers. CONTEXT
291 is modified to include only the selected element."
292 (cl-check-type context cons)
293 (let-alist context
294 (if (cdr .HeaderInfos)
295 (clang-include-fixer--prompt-for-header context)
296 (message "Only one include is missing: %s"
297 (let-alist (car .HeaderInfos) .Header))))
298 nil)
299
300 (defvar clang-include-fixer--history nil
301 "History for `clang-include-fixer--prompt-for-header'.")
302
303 (defun clang-include-fixer--prompt-for-header (context)
304 "Prompt the user for a single header.
305 The choices are taken from the HeaderInfo elements in CONTEXT.
306 They are replaced by the single element selected by the user."
307 (let-alist context
308 (let ((symbol (clang-include-fixer--symbol-name .QuerySymbolInfos))
309 ;; Add temporary highlighting so that the user knows which
310 ;; symbols the current session is about.
311 (overlays (remove nil
312 (mapcar #'clang-include-fixer--highlight .QuerySymbolInfos))))
313 (unwind-protect
314 (save-excursion
315 ;; While prompting, go to the closest overlay so that the user sees
316 ;; some context.
317 (when overlays
318 (goto-char (clang-include-fixer--closest-overlay overlays)))
319 (cl-flet ((header (info) (let-alist info .Header)))
320 ;; The header-infos is already sorted by clang-include-fixer.
321 (let* ((headers (mapcar #'header .HeaderInfos))
322 (header (completing-read
323 (clang-include-fixer--format-message
324 "Select include for '%s': " symbol)
325 headers nil :require-match nil
326 'clang-include-fixer--history
327 ;; Specify a default to prevent the behavior
328 ;; described in
329 ;; 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.
330 (car headers)))
331 (info (cl-find header .HeaderInfos :key #'header :test #'string=)))
332 (unless info (user-error "No header selected"))
333 (setcar .HeaderInfos info)
334 (setcdr .HeaderInfos nil))))
335 (mapc #'delete-overlay overlays)))))
336
337 (defun clang-include-fixer--symbol-name (symbol-infos)
338 "Return the unique symbol name in SYMBOL-INFOS.
339 Raise a signal if the symbol name is not unique."
340 (let ((symbols (delete-dups (mapcar (lambda (info)
341 (let-alist info .RawIdentifier))
342 symbol-infos))))
343 (when (cdr symbols)
344 (error "Multiple symbols %s returned" symbols))
345 (car symbols)))
346
347 (defun clang-include-fixer--highlight (symbol-info)
348 "Add an overlay to highlight SYMBOL-INFO, if it points to a non-empty range.
349 Return the overlay object, or nil."
350 (let-alist symbol-info
351 (unless (zerop .Range.Length)
352 (let ((overlay (make-overlay
353 (clang-include-fixer--filepos-to-bufferpos
354 .Range.Offset 'approximate)
355 (clang-include-fixer--filepos-to-bufferpos
356 (+ .Range.Offset .Range.Length) 'approximate))))
357 (overlay-put overlay 'face 'clang-include-fixer-highlight)
358 overlay))))
359
360 (defun clang-include-fixer--closest-overlay (overlays)
361 "Return the start of the overlay in OVERLAYS that is closest to point."
362 (cl-check-type overlays cons)
363 (let ((point (point))
364 acc)
365 (dolist (overlay overlays acc)
366 (let ((start (overlay-start overlay)))
367 (when (or (null acc) (< (abs (- point start)) (abs (- point acc))))
368 (setq acc start))))))
369
370 (defun clang-include-fixer--parse-json (buffer)
371 "Parse a JSON response from clang-include-fixer in BUFFER.
372 Return the JSON object as an association list."
373 (with-current-buffer buffer
374 (save-excursion
375 (goto-char (point-min))
376 (let ((json-object-type 'alist)
377 (json-array-type 'list)
378 (json-key-type 'symbol)
379 (json-false :json-false)
380 (json-null nil)
381 (json-pre-element-read-function nil)
382 (json-post-element-read-function nil))
383 (json-read)))))
384
385 (defun clang-include-fixer--encode-json (object)
386 "Return the JSON representation of OBJECT as a string."
387 (let ((json-encoding-separator ",")
388 (json-encoding-default-indentation " ")
389 (json-encoding-pretty-print nil)
390 (json-encoding-lisp-style-closings nil)
391 (json-encoding-object-sort-predicate nil))
392 (json-encode object)))
393
394 (defun clang-include-fixer--symbol-at-point ()
395 "Return the qualified symbol at point.
396 If there is no symbol at point, return nil."
397 ;; Let ‘bounds-of-thing-at-point’ to do the hard work and deal with edge
398 ;; cases.
399 (let ((bounds (bounds-of-thing-at-point 'symbol)))
400 (when bounds
401 (let ((beg (car bounds))
402 (end (cdr bounds)))
403 (save-excursion
404 ;; Extend the symbol range to the left. Skip over namespace
405 ;; delimiters and parent namespace names.
406 (goto-char beg)
407 (while (and (clang-include-fixer--skip-double-colon-backward)
408 (skip-syntax-backward "w_")))
409 ;; Skip over one more namespace delimiter, for absolute names.
410 (clang-include-fixer--skip-double-colon-backward)
411 (setq beg (point))
412 ;; Extend the symbol range to the right. Skip over namespace
413 ;; delimiters and child namespace names.
414 (goto-char end)
415 (while (and (clang-include-fixer--skip-double-colon-forward)
416 (skip-syntax-forward "w_")))
417 (setq end (point)))
418 (buffer-substring-no-properties beg end)))))
419
420 (defun clang-include-fixer--skip-double-colon-forward ()
421 "Skip a double colon.
422 When the next two characters are '::', skip them and return
423 non-nil. Otherwise return nil."
424 (let ((end (+ (point) 2)))
425 (when (and (<= end (point-max))
426 (string-equal (buffer-substring-no-properties (point) end) "::"))
427 (goto-char end)
428 t)))
429
430 (defun clang-include-fixer--skip-double-colon-backward ()
431 "Skip a double colon.
432 When the previous two characters are '::', skip them and return
433 non-nil. Otherwise return nil."
434 (let ((beg (- (point) 2)))
435 (when (and (>= beg (point-min))
436 (string-equal (buffer-substring-no-properties beg (point)) "::"))
437 (goto-char beg)
438 t)))
439
440 ;; ‘filepos-to-bufferpos’ is new in Emacs 25.1. Provide a fallback for older
441 ;; versions.
442 (defalias 'clang-include-fixer--filepos-to-bufferpos
443 (if (fboundp 'filepos-to-bufferpos)
444 'filepos-to-bufferpos
445 (lambda (byte &optional _quality _coding-system)
446 (byte-to-position (1+ byte)))))
447
448 ;; ‘format-message’ is new in Emacs 25.1. Provide a fallback for older
449 ;; versions.
450 (defalias 'clang-include-fixer--format-message
451 (if (fboundp 'format-message) 'format-message 'format))
452
453 ;; ‘file-local-name’ is new in Emacs 26.1. Provide a fallback for older
454 ;; versions.
455 (defalias 'clang-include-fixer--file-local-name
456 (if (fboundp 'file-local-name) #'file-local-name
457 (lambda (file) (or (file-remote-p file 'localname) file))))
458
459 (provide 'clang-include-fixer)
460 ;;; clang-include-fixer.el ends here