dotemacs

My Emacs configuration
git clone git://git.entf.net/dotemacs
Log | Files | Refs | LICENSE

consult-compile.el (4817B)

      1 ;;; consult-compile.el --- Provides the command `consult-compile-error' -*- lexical-binding: t -*-
      2 
      3 ;; Copyright (C) 2021-2024 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 (pos-eol)))
     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