consult-compile.el (4825B)
1 ;;; consult-compile.el --- Provides the command `consult-compile-error' -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021-2023 Free Software Foundation, Inc. 4 5 ;; This file is part of GNU Emacs. 6 7 ;; This program is free software: you can redistribute it and/or modify 8 ;; it under the terms of the GNU General Public License as published by 9 ;; the Free Software Foundation, either version 3 of the License, or 10 ;; (at your option) any later version. 11 12 ;; This program is distributed in the hope that it will be useful, 13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;; GNU General Public License for more details. 16 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 19 20 ;;; Commentary: 21 22 ;; Provides the command `consult-compile-error'. This is an extra 23 ;; package, to allow lazy loading of compile.el. The 24 ;; `consult-compile-error' command is autoloaded. 25 26 ;;; Code: 27 28 (require 'consult) 29 (require 'compile) 30 31 (defvar consult-compile--history nil) 32 33 (defconst consult-compile--narrow 34 '((?e . "Error") 35 (?w . "Warning") 36 (?i . "Info"))) 37 38 (defun consult-compile--font-lock (str) 39 "Apply `font-lock' faces in STR, copy them to `face'." 40 (let ((pos 0) (len (length str))) 41 (while (< pos len) 42 (let* ((face (get-text-property pos 'font-lock-face str)) 43 (end (or (text-property-not-all pos len 'font-lock-face face str) len))) 44 (put-text-property pos end 'face face str) 45 (setq pos end))) 46 str)) 47 48 (defun consult-compile--error-candidates (buffer) 49 "Return alist of errors and positions in BUFFER, a compilation buffer." 50 (with-current-buffer buffer 51 (let ((candidates) 52 (pos (point-min))) 53 (save-excursion 54 (while (setq pos (compilation-next-single-property-change pos 'compilation-message)) 55 (when-let (msg (get-text-property pos 'compilation-message)) 56 (goto-char pos) 57 (push (propertize 58 (consult-compile--font-lock (consult--buffer-substring pos (line-end-position))) 59 'consult--type (pcase (compilation--message->type msg) 60 (0 ?i) 61 (1 ?w) 62 (_ ?e)) 63 'consult--candidate (point-marker)) 64 candidates)))) 65 (nreverse candidates)))) 66 67 (defun consult-compile--lookup (marker) 68 "Lookup error position given error MARKER." 69 (when-let (buffer (and marker (marker-buffer marker))) 70 (with-current-buffer buffer 71 (let ((next-error-highlight nil) 72 (compilation-current-error marker) 73 (overlay-arrow-position overlay-arrow-position)) 74 (ignore-errors 75 (save-window-excursion 76 (compilation-next-error-function 0) 77 (point-marker))))))) 78 79 (defun consult-compile--compilation-buffers (file) 80 "Return a list of compilation buffers relevant to FILE." 81 (consult--buffer-query 82 :sort 'alpha :predicate 83 (lambda (buffer) 84 (with-current-buffer buffer 85 (and (compilation-buffer-internal-p) 86 (file-in-directory-p file default-directory)))))) 87 88 (defun consult-compile--state () 89 "Like `consult--jump-state', also setting the current compilation error." 90 (let ((jump (consult--jump-state))) 91 (lambda (action marker) 92 (let ((pos (consult-compile--lookup marker))) 93 (when-let (buffer (and (eq action 'return) 94 marker 95 (marker-buffer marker))) 96 (with-current-buffer buffer 97 (setq compilation-current-error marker 98 overlay-arrow-position marker))) 99 (funcall jump action pos))))) 100 101 ;;;###autoload 102 (defun consult-compile-error () 103 "Jump to a compilation error in the current buffer. 104 105 This command collects entries from compilation buffers and grep 106 buffers related to the current buffer. The command supports 107 preview of the currently selected error." 108 (interactive) 109 (consult--read 110 (or (mapcan #'consult-compile--error-candidates 111 (or (consult-compile--compilation-buffers 112 default-directory) 113 (user-error "No compilation buffers found for the current buffer"))) 114 (user-error "No compilation errors found")) 115 :prompt "Go to error: " 116 :category 'consult-compile-error 117 :sort nil 118 :require-match t 119 :history t ;; disable history 120 :lookup #'consult--lookup-candidate 121 :group (consult--type-group consult-compile--narrow) 122 :narrow (consult--type-narrow consult-compile--narrow) 123 :history '(:input consult-compile--history) 124 :state (consult-compile--state))) 125 126 (provide 'consult-compile) 127 ;;; consult-compile.el ends here