cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/lmcompile.el

   1 ;;; lmcompile.el --- highlight compile error lines
   2
   3 ;;
   4 ;; Author: Eric M. Ludlam <eludlam@mathworks.com>
   5 ;; Maintainer: Eric M. Ludlam <eludlam@mathworks.com>
   6 ;; Keywords: lisp
   7 ;;
   8 ;; Copyright (C) 2003, 2004, 2005 Eric M. Ludlam
   9 ;;
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24 ;;
  25 ;;; Commentary:
  26 ;;
  27 ;;  This package uses the compile package, and the linemark package to
  28 ;; highlight all lines showing errors.
  29
  30 ;;; Notes:
  31 ;;
  32 ;; Thanks to Markus Gritsch for adding support for grep-buffers, where
  33 ;; no file is associated with a buffer.  (Similar work in linemark.el)
  34
  35 (require 'linemark)
  36
  37 ;;; Code:
  38 (defclass lmcompile-linemark-group (linemark-group)
  39   (
  40    )
  41   "Linemark Group for compile error highlights.")
  42
  43 (defclass lmcompile-linemark-entry (linemark-entry)
  44   ((errormarker :initarg :errormarker
  45                 :type marker
  46                 :documentation
  47                 "Marker pointing to the source of the match.")
  48    (errmsg :initarg :errmsg
  49            :type string
  50            :documentation
  51            "The match text of the error in question.")
  52    )
  53   "Linemark Group for one compile error highlight.
  54 Tracks additional information about the error.")
  55
  56 (defmethod linemark-new-entry ((g linemark-group) &rest args)
  57   "Create a new entry for G using init ARGS."
  58   (let ((f (plist-get args :filename))
  59         (l (plist-get args :line)))
  60     (apply 'lmcompile-linemark-entry (format "%s %d" f l)
  61            args)))
  62
  63 (defmethod linemark-display ((e lmcompile-linemark-entry) active-p)
  64   "Set object E to be active or inactive."
  65   ;; Do the rest of our work
  66   (call-next-method)
  67
  68   ;; Add a tool tip
  69   (when (and active-p
  70              (slot-boundp e 'overlay)
  71              (oref e overlay)
  72              (slot-boundp e 'errmsg)
  73              )
  74
  75     (linemark-overlay-put (oref e overlay)
  76                           'help-echo
  77                           (oref e errmsg))
  78     )
  79   )
  80
  81 (defun lmcompile-create-group (name)
  82   "Create a group object for tracking linemark entries.
  83 Do not permit multiple groups with the same NAME."
  84   (let ((newgroup (lmcompile-linemark-group name))
  85         (foundgroup nil)
  86         (lmg linemark-groups))
  87     (while (and (not foundgroup) lmg)
  88       (if (string= name (object-name-string (car lmg)))
  89           (setq foundgroup (car lmg)))
  90       (setq lmg (cdr lmg)))
  91     (if foundgroup
  92         (setq newgroup foundgroup)
  93       (setq linemark-groups (cons newgroup linemark-groups))
  94       newgroup)))
  95
  96 (defvar lmcompile-error-group
  97   (linemark-new-group 'lmcompile-linemark-group "compiler errors")
  98   "The LMCOMPILE error group object.")
  99
 100 (defun lmcompile-clear ()
 101   "Flush all compile error entries."
 102   (interactive)
 103   (mapcar (lambda (e) (linemark-delete e))
 104           (oref lmcompile-error-group marks)))
 105
 106 ;; Compatibility
 107 (if (fboundp 'compile-reinitialize-errors)
 108     (defalias 'lmcompile-reinitialize-errors 'compile-reinitialize-errors)
 109   ;; Newer versions of Emacs:
 110   (defun lmcompile-reinitialize-errors (&rest foo)
 111     "Find out what this should be."
 112     (error "Need replacement for `compile-reinitialize-errors")
 113     )
 114   )
 115
 116 ;;;###autoload
 117 (defun lmcompile-do-highlight ()
 118   "Do compilation mode highlighting.
 119 Works on grep, compile, or other type mode."
 120   (interactive)
 121
 122   ;; Flush out the old
 123   (lmcompile-clear)
 124
 125   ;; Set the buffer appropriately
 126   (setq compilation-last-buffer (compilation-find-buffer))
 127
 128   ;; Get the list of errors to be activated.
 129   (lmcompile-reinitialize-errors nil)
 130
 131   (let ((marks
 132          (save-excursion
 133            (set-buffer compilation-last-buffer)
 134            compilation-error-list))
 135         )
 136     (while marks
 137       (let (errmark
 138             file
 139             line
 140             (face nil)
 141             (case-fold-search t)
 142             (entry nil)
 143             (txt nil)
 144             )
 145
 146         (setq errmark (car (car marks)))
 147         (if (listp (cdr (car marks)))
 148             (progn ; So a list containing filename, linenumber, ... like (grep) provides is used.
 149               (setq file (nth 1 (car marks)))
 150               (setq line (nth 2 (car marks)))
 151
 152               (setq file (concat (car (cdr file))
 153                                  (car file)))
 154
 155               ;; In case file contains an absolute path, the above doesn't work, at least not on Win32.  Use this version.
 156               ;; Originally suggested by: Markus Gritsch
 157               (if (not (file-exists-p file))
 158                   (setq file (car (nth 1 (car marks))))))
 159
 160           (progn ; Otherwise we assume that we have a marker, which works also on buffers which have no file associated.
 161             (setq file (buffer-name (marker-buffer (cdr (car marks)))))
 162
 163             (setq line (save-excursion
 164                          (set-buffer (marker-buffer (cdr (car marks))))
 165                          (save-excursion
 166                            (goto-char (cdr (car marks)))
 167                            (count-lines 1 (1+ (point))))))))
 168
 169         ;; We've got the goods, lets add in an entry.
 170         ;; If we can't find the file, skip it.  It'll be
 171         ;; found eventually.
 172         (when (or (file-exists-p file) (bufferp (marker-buffer (cdr (car marks)))))
 173
 174           (condition-case nil
 175               (save-excursion
 176                 (set-buffer (marker-buffer errmark))
 177                 (save-excursion
 178                   (goto-char errmark)
 179
 180                   (setq face (cond
 181                               ((re-search-forward "error" (point-at-eol) t)
 182                                'linemark-stop-face)
 183                               ((re-search-forward "warning" (point-at-eol) t)
 184                                'linemark-caution-face)
 185                               (t
 186                                'linemark-go-face)))))
 187             (error nil))
 188
 189           (condition-case nil
 190               (save-excursion
 191                 (set-buffer (marker-buffer errmark))
 192                 (save-excursion
 193                   (goto-char errmark)
 194                   (setq txt (buffer-substring-no-properties
 195                              (point-at-bol) (point-at-eol)))
 196                   ;; Strip positional information
 197                   (while (string-match "[0-9]:" txt)
 198                     (setq txt (substring txt (match-end 0))))
 199                   ;; Strip leading whitespace (if any)
 200                   (when (string-match "^\\s-++" txt)
 201                     (setq txt (substring txt (match-end 0))))
 202                   ))
 203             (error nil))
 204
 205           (setq entry
 206                 (linemark-add-entry
 207                  lmcompile-error-group
 208                  :filename file
 209                  :line line
 210                  :errormarker errmark
 211                  :face face
 212                  :errmsg txt
 213                  ))
 214
 215           ))
 216       (setq marks (cdr marks)))))
 217
 218 (provide 'lmcompile)
 219
 220 ;;; lmcompile.el ends here