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.
25The first argument is the filename of the include, the second argument is
26non-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
32A 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.
40This 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.
52This 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.
82When 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.
90The current file name is passed after ARGS as last argument.  If
91the call was successful the returned result is stored in a
92temporary buffer, and CALLBACK is called with the temporary
93buffer 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'.
114CALLBACK is called after the process finishes successfully; it is
115called with a single argument, the buffer where standard output
116has been inserted.  ARGS is a list of additional command line
117arguments.  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'.
133CALLBACK is called after the process finishes successfully; it is
134called with a single argument, the buffer where standard output
135has been inserted.  ARGS is a list of additional command line
136arguments.  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.
151Returns a list; the first element is the binary to
152execute (`clang-include-fixer-executable'), and the remaining
153elements are the command line arguments.  Adds proper arguments
154for `clang-include-fixer-input-format' and
155`clang-include-fixer-init-string'.  Appends the current buffer's
156file 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.
167STDIN, STDOUT, and STDERR are buffers for the standard streams;
168only STDERR may be nil.  CALLBACK is called in the case of
169success; it is called with a single argument, STDOUT.  On
170failure, 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.
205FROM and TO must be buffers.  If the contents of FROM and TO are
206equal, do nothing and return non-nil.  If FROM contains a single
207line missing from TO, insert that line into TO so that the buffer
208contents are equal and return non-nil.  Otherwise, do nothing and
209return 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.
247Add a missing header if there is any.  If there are multiple
248possible headers the user can select one of them to be included.
249Temporarily highlight the affected symbols.  Asynchronously call
250clang-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.
288CONTEXT must be a clang-include-fixer context object in
289association list format.  If it contains more than one HeaderInfo
290element, prompt the user to select one of the headers.  CONTEXT
291is 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.
305The choices are taken from the HeaderInfo elements in CONTEXT.
306They 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.
339Raise 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.
349Return 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.
372Return 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.
396If 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.
422When the next two characters are '::', skip them and return
423non-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.
432When the previous two characters are '::', skip them and return
433non-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
461