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/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 (fboundp 'make-process) 97 ;; Prefer using ‘make-process’ if available, because 98 ;; ‘start-process’ doesn’t allow us to separate the 99 ;; standard error from the output. 100 (clang-include-fixer--make-process callback args) 101 (clang-include-fixer--start-process callback args)))) 102 (save-restriction 103 (widen) 104 (process-send-region process (point-min) (point-max))) 105 (process-send-eof process)) 106 nil) 107 108(defun clang-include-fixer--make-process (callback args) 109 "Start a new clang-incude-fixer process using `make-process'. 110CALLBACK is called after the process finishes successfully; it is 111called with a single argument, the buffer where standard output 112has been inserted. ARGS is a list of additional command line 113arguments. Return the new process object." 114 (let ((stdin (current-buffer)) 115 (stdout (generate-new-buffer "*clang-include-fixer output*")) 116 (stderr (generate-new-buffer "*clang-include-fixer errors*"))) 117 (make-process :name "clang-include-fixer" 118 :buffer stdout 119 :command (clang-include-fixer--command args) 120 :coding 'utf-8-unix 121 :noquery t 122 :connection-type 'pipe 123 :sentinel (clang-include-fixer--sentinel stdin stdout stderr 124 callback) 125 :stderr stderr))) 126 127(defun clang-include-fixer--start-process (callback args) 128 "Start a new clang-incude-fixer process using `start-process'. 129CALLBACK is called after the process finishes successfully; it is 130called with a single argument, the buffer where standard output 131has been inserted. ARGS is a list of additional command line 132arguments. Return the new process object." 133 (let* ((stdin (current-buffer)) 134 (stdout (generate-new-buffer "*clang-include-fixer output*")) 135 (process-connection-type nil) 136 (process (apply #'start-process "clang-include-fixer" stdout 137 (clang-include-fixer--command args)))) 138 (set-process-coding-system process 'utf-8-unix 'utf-8-unix) 139 (set-process-query-on-exit-flag process nil) 140 (set-process-sentinel process 141 (clang-include-fixer--sentinel stdin stdout nil 142 callback)) 143 process)) 144 145(defun clang-include-fixer--command (args) 146 "Return the clang-include-fixer command line. 147Returns a list; the first element is the binary to 148execute (`clang-include-fixer-executable'), and the remaining 149elements are the command line arguments. Adds proper arguments 150for `clang-include-fixer-input-format' and 151`clang-include-fixer-init-string'. Appends the current buffer's 152file name; prepends ARGS directly in front of it." 153 (cl-check-type args list) 154 `(,clang-include-fixer-executable 155 ,(format "-db=%s" clang-include-fixer-input-format) 156 ,(format "-input=%s" clang-include-fixer-init-string) 157 "-stdin" 158 ,@args 159 ,(buffer-file-name))) 160 161(defun clang-include-fixer--sentinel (stdin stdout stderr callback) 162 "Return a process sentinel for clang-include-fixer processes. 163STDIN, STDOUT, and STDERR are buffers for the standard streams; 164only STDERR may be nil. CALLBACK is called in the case of 165success; it is called with a single argument, STDOUT. On 166failure, a buffer containing the error output is displayed." 167 (cl-check-type stdin buffer-live) 168 (cl-check-type stdout buffer-live) 169 (cl-check-type stderr (or null buffer-live)) 170 (cl-check-type callback function) 171 (lambda (process event) 172 (cl-check-type process process) 173 (cl-check-type event string) 174 (unwind-protect 175 (if (string-equal event "finished\n") 176 (progn 177 (when stderr (kill-buffer stderr)) 178 (with-current-buffer stdin 179 (funcall callback stdout)) 180 (kill-buffer stdout)) 181 (when stderr (kill-buffer stdout)) 182 (message "clang-include-fixer failed") 183 (with-current-buffer (or stderr stdout) 184 (insert "\nProcess " (process-name process) 185 ?\s event)) 186 (display-buffer (or stderr stdout)))) 187 nil)) 188 189(defun clang-include-fixer--replace-buffer (stdout) 190 "Replace current buffer by content of STDOUT." 191 (cl-check-type stdout buffer-live) 192 (barf-if-buffer-read-only) 193 (cond ((fboundp 'replace-buffer-contents) (replace-buffer-contents stdout)) 194 ((clang-include-fixer--insert-line stdout (current-buffer))) 195 (t (erase-buffer) (insert-buffer-substring stdout))) 196 (message "Fix applied") 197 nil) 198 199(defun clang-include-fixer--insert-line (from to) 200 "Insert a single missing line from the buffer FROM into TO. 201FROM and TO must be buffers. If the contents of FROM and TO are 202equal, do nothing and return non-nil. If FROM contains a single 203line missing from TO, insert that line into TO so that the buffer 204contents are equal and return non-nil. Otherwise, do nothing and 205return nil. Buffer restrictions are ignored." 206 (cl-check-type from buffer-live) 207 (cl-check-type to buffer-live) 208 (with-current-buffer from 209 (save-excursion 210 (save-restriction 211 (widen) 212 (with-current-buffer to 213 (save-excursion 214 (save-restriction 215 (widen) 216 ;; Search for the first buffer difference. 217 (let ((chars (abs (compare-buffer-substrings to nil nil from nil nil)))) 218 (if (zerop chars) 219 ;; Buffer contents are equal, nothing to do. 220 t 221 (goto-char chars) 222 ;; We might have ended up in the middle of a line if the 223 ;; current line partially matches. In this case we would 224 ;; have to insert more than a line. Move to the beginning of 225 ;; the line to avoid this situation. 226 (beginning-of-line) 227 (with-current-buffer from 228 (goto-char chars) 229 (beginning-of-line) 230 (let ((from-begin (point)) 231 (from-end (progn (forward-line) (point))) 232 (to-point (with-current-buffer to (point)))) 233 ;; Search for another buffer difference after the line in 234 ;; question. If there is none, we can proceed. 235 (when (zerop (compare-buffer-substrings from from-end nil 236 to to-point nil)) 237 (with-current-buffer to 238 (insert-buffer-substring from from-begin from-end)) 239 t)))))))))))) 240 241(defun clang-include-fixer--add-header (stdout) 242 "Analyse the result of include-fixer stored in STDOUT. 243Add a missing header if there is any. If there are multiple 244possible headers the user can select one of them to be included. 245Temporarily highlight the affected symbols. Asynchronously call 246clang-include-fixer to insert the selected header." 247 (cl-check-type stdout buffer-live) 248 (let ((context (clang-include-fixer--parse-json stdout))) 249 (let-alist context 250 (cond 251 ((null .QuerySymbolInfos) 252 (message "The file is fine, no need to add a header.")) 253 ((null .HeaderInfos) 254 (message "Couldn't find header for '%s'" 255 (let-alist (car .QuerySymbolInfos) .RawIdentifier))) 256 (t 257 ;; Users may C-g in prompts, make sure the process sentinel 258 ;; behaves correctly. 259 (with-local-quit 260 ;; Replace the HeaderInfos list by a single header selected by 261 ;; the user. 262 (clang-include-fixer--select-header context) 263 ;; Call clang-include-fixer again to insert the selected header. 264 (clang-include-fixer--start 265 (let ((old-tick (buffer-chars-modified-tick))) 266 (lambda (stdout) 267 (when (/= old-tick (buffer-chars-modified-tick)) 268 ;; Replacing the buffer now would undo the user’s changes. 269 (user-error (concat "The buffer has been changed " 270 "before the header could be inserted"))) 271 (clang-include-fixer--replace-buffer stdout) 272 (let-alist context 273 (let-alist (car .HeaderInfos) 274 (with-local-quit 275 (run-hook-with-args 'clang-include-fixer-add-include-hook 276 (substring .Header 1 -1) 277 (string= (substring .Header 0 1) "<"))))))) 278 (format "-insert-header=%s" 279 (clang-include-fixer--encode-json context)))))))) 280 nil) 281 282(defun clang-include-fixer--select-header (context) 283 "Prompt the user for a header if necessary. 284CONTEXT must be a clang-include-fixer context object in 285association list format. If it contains more than one HeaderInfo 286element, prompt the user to select one of the headers. CONTEXT 287is modified to include only the selected element." 288 (cl-check-type context cons) 289 (let-alist context 290 (if (cdr .HeaderInfos) 291 (clang-include-fixer--prompt-for-header context) 292 (message "Only one include is missing: %s" 293 (let-alist (car .HeaderInfos) .Header)))) 294 nil) 295 296(defvar clang-include-fixer--history nil 297 "History for `clang-include-fixer--prompt-for-header'.") 298 299(defun clang-include-fixer--prompt-for-header (context) 300 "Prompt the user for a single header. 301The choices are taken from the HeaderInfo elements in CONTEXT. 302They are replaced by the single element selected by the user." 303 (let-alist context 304 (let ((symbol (clang-include-fixer--symbol-name .QuerySymbolInfos)) 305 ;; Add temporary highlighting so that the user knows which 306 ;; symbols the current session is about. 307 (overlays (remove nil 308 (mapcar #'clang-include-fixer--highlight .QuerySymbolInfos)))) 309 (unwind-protect 310 (save-excursion 311 ;; While prompting, go to the closest overlay so that the user sees 312 ;; some context. 313 (when overlays 314 (goto-char (clang-include-fixer--closest-overlay overlays))) 315 (cl-flet ((header (info) (let-alist info .Header))) 316 ;; The header-infos is already sorted by include-fixer. 317 (let* ((header (completing-read 318 (clang-include-fixer--format-message 319 "Select include for '%s': " symbol) 320 (mapcar #'header .HeaderInfos) 321 nil :require-match nil 322 'clang-include-fixer--history)) 323 (info (cl-find header .HeaderInfos :key #'header :test #'string=))) 324 (cl-assert info) 325 (setcar .HeaderInfos info) 326 (setcdr .HeaderInfos nil)))) 327 (mapc #'delete-overlay overlays))))) 328 329(defun clang-include-fixer--symbol-name (symbol-infos) 330 "Return the unique symbol name in SYMBOL-INFOS. 331Raise a signal if the symbol name is not unique." 332 (let ((symbols (delete-dups (mapcar (lambda (info) 333 (let-alist info .RawIdentifier)) 334 symbol-infos)))) 335 (when (cdr symbols) 336 (error "Multiple symbols %s returned" symbols)) 337 (car symbols))) 338 339(defun clang-include-fixer--highlight (symbol-info) 340 "Add an overlay to highlight SYMBOL-INFO, if it points to a non-empty range. 341Return the overlay object, or nil." 342 (let-alist symbol-info 343 (unless (zerop .Range.Length) 344 (let ((overlay (make-overlay 345 (clang-include-fixer--filepos-to-bufferpos 346 .Range.Offset 'approximate) 347 (clang-include-fixer--filepos-to-bufferpos 348 (+ .Range.Offset .Range.Length) 'approximate)))) 349 (overlay-put overlay 'face 'clang-include-fixer-highlight) 350 overlay)))) 351 352(defun clang-include-fixer--closest-overlay (overlays) 353 "Return the start of the overlay in OVERLAYS that is closest to point." 354 (cl-check-type overlays cons) 355 (let ((point (point)) 356 acc) 357 (dolist (overlay overlays acc) 358 (let ((start (overlay-start overlay))) 359 (when (or (null acc) (< (abs (- point start)) (abs (- point acc)))) 360 (setq acc start)))))) 361 362(defun clang-include-fixer--parse-json (buffer) 363 "Parse a JSON response from clang-include-fixer in BUFFER. 364Return the JSON object as an association list." 365 (with-current-buffer buffer 366 (save-excursion 367 (goto-char (point-min)) 368 (let ((json-object-type 'alist) 369 (json-array-type 'list) 370 (json-key-type 'symbol) 371 (json-false :json-false) 372 (json-null nil) 373 (json-pre-element-read-function nil) 374 (json-post-element-read-function nil)) 375 (json-read))))) 376 377(defun clang-include-fixer--encode-json (object) 378 "Return the JSON representation of OBJECT as a string." 379 (let ((json-encoding-separator ",") 380 (json-encoding-default-indentation " ") 381 (json-encoding-pretty-print nil) 382 (json-encoding-lisp-style-closings nil) 383 (json-encoding-object-sort-predicate nil)) 384 (json-encode object))) 385 386(defun clang-include-fixer--symbol-at-point () 387 "Return the qualified symbol at point. 388If there is no symbol at point, return nil." 389 ;; Let ‘bounds-of-thing-at-point’ to do the hard work and deal with edge 390 ;; cases. 391 (let ((bounds (bounds-of-thing-at-point 'symbol))) 392 (when bounds 393 (let ((beg (car bounds)) 394 (end (cdr bounds))) 395 (save-excursion 396 ;; Extend the symbol range to the left. Skip over namespace 397 ;; delimiters and parent namespace names. 398 (goto-char beg) 399 (while (and (clang-include-fixer--skip-double-colon-backward) 400 (skip-syntax-backward "w_"))) 401 ;; Skip over one more namespace delimiter, for absolute names. 402 (clang-include-fixer--skip-double-colon-backward) 403 (setq beg (point)) 404 ;; Extend the symbol range to the right. Skip over namespace 405 ;; delimiters and child namespace names. 406 (goto-char end) 407 (while (and (clang-include-fixer--skip-double-colon-forward) 408 (skip-syntax-forward "w_"))) 409 (setq end (point))) 410 (buffer-substring-no-properties beg end))))) 411 412(defun clang-include-fixer--skip-double-colon-forward () 413 "Skip a double colon. 414When the next two characters are '::', skip them and return 415non-nil. Otherwise return nil." 416 (let ((end (+ (point) 2))) 417 (when (and (<= end (point-max)) 418 (string-equal (buffer-substring-no-properties (point) end) "::")) 419 (goto-char end) 420 t))) 421 422(defun clang-include-fixer--skip-double-colon-backward () 423 "Skip a double colon. 424When the previous two characters are '::', skip them and return 425non-nil. Otherwise return nil." 426 (let ((beg (- (point) 2))) 427 (when (and (>= beg (point-min)) 428 (string-equal (buffer-substring-no-properties beg (point)) "::")) 429 (goto-char beg) 430 t))) 431 432;; ‘filepos-to-bufferpos’ is new in Emacs 25.1. Provide a fallback for older 433;; versions. 434(defalias 'clang-include-fixer--filepos-to-bufferpos 435 (if (fboundp 'filepos-to-bufferpos) 436 'filepos-to-bufferpos 437 (lambda (byte &optional _quality _coding-system) 438 (byte-to-position (1+ byte))))) 439 440;; ‘format-message’ is new in Emacs 25.1. Provide a fallback for older 441;; versions. 442(defalias 'clang-include-fixer--format-message 443 (if (fboundp 'format-message) 'format-message 'format)) 444 445(provide 'clang-include-fixer) 446;;; clang-include-fixer.el ends here 447