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