Initial Commit

[temp.git] / site-lisp / cedet-1.0pre4 / eieio / lmcompile.el

;;; lmcompile.el --- highlight compile error lines

;;
;; Author: Eric M. Ludlam <eludlam@mathworks.com>
;; Maintainer: Eric M. Ludlam <eludlam@mathworks.com>
;; Keywords: lisp
;;
;; Copyright (C) 2003, 2004, 2005 Eric M. Ludlam
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;;; Commentary:
;;
;;  This package uses the compile package, and the linemark package to
;; highlight all lines showing errors.

;;; Notes:
;;
;; Thanks to Markus Gritsch for adding support for grep-buffers, where
;; no file is associated with a buffer.  (Similar work in linemark.el)

(require 'linemark)

;;; Code:
(defclass lmcompile-linemark-group (linemark-group)
  (
   )
  "Linemark Group for compile error highlights.")

(defclass lmcompile-linemark-entry (linemark-entry)
  ((errormarker :initarg :errormarker
                :type marker
                :documentation
                "Marker pointing to the source of the match.")
   (errmsg :initarg :errmsg
           :type string
           :documentation
           "The match text of the error in question.")
   )
  "Linemark Group for one compile error highlight.
Tracks additional information about the error.")

(defmethod linemark-new-entry ((g linemark-group) &rest args)
  "Create a new entry for G using init ARGS."
  (let ((f (plist-get args :filename))
        (l (plist-get args :line)))
    (apply 'lmcompile-linemark-entry (format "%s %d" f l)
           args)))

(defmethod linemark-display ((e lmcompile-linemark-entry) active-p)
  "Set object E to be active or inactive."
  ;; Do the rest of our work
  (call-next-method)

  ;; Add a tool tip
  (when (and active-p
             (slot-boundp e 'overlay)
             (oref e overlay)
             (slot-boundp e 'errmsg)
             )

    (linemark-overlay-put (oref e overlay)
                          'help-echo
                          (oref e errmsg))
    )
  )

(defun lmcompile-create-group (name)
  "Create a group object for tracking linemark entries.
Do not permit multiple groups with the same NAME."
  (let ((newgroup (lmcompile-linemark-group name))
        (foundgroup nil)
        (lmg linemark-groups))
    (while (and (not foundgroup) lmg)
      (if (string= name (object-name-string (car lmg)))
          (setq foundgroup (car lmg)))
      (setq lmg (cdr lmg)))
    (if foundgroup
        (setq newgroup foundgroup)
      (setq linemark-groups (cons newgroup linemark-groups))
      newgroup)))

(defvar lmcompile-error-group
  (linemark-new-group 'lmcompile-linemark-group "compiler errors")
  "The LMCOMPILE error group object.")

(defun lmcompile-clear ()
  "Flush all compile error entries."
  (interactive)
  (mapcar (lambda (e) (linemark-delete e))
          (oref lmcompile-error-group marks)))

;; Compatibility
(if (fboundp 'compile-reinitialize-errors)
    (defalias 'lmcompile-reinitialize-errors 'compile-reinitialize-errors)
  ;; Newer versions of Emacs:
  (defun lmcompile-reinitialize-errors (&rest foo)
    "Find out what this should be."
    (error "Need replacement for `compile-reinitialize-errors")
    )
  )

;;;###autoload
(defun lmcompile-do-highlight ()
  "Do compilation mode highlighting.
Works on grep, compile, or other type mode."
  (interactive)

  ;; Flush out the old
  (lmcompile-clear)

  ;; Set the buffer appropriately
  (setq compilation-last-buffer (compilation-find-buffer))

  ;; Get the list of errors to be activated.
  (lmcompile-reinitialize-errors nil)
  
  (let ((marks
         (save-excursion
           (set-buffer compilation-last-buffer)
           compilation-error-list))
        )
    (while marks
      (let (errmark
            file
            line
            (face nil)
            (case-fold-search t)
            (entry nil)
            (txt nil)
            )

        (setq errmark (car (car marks)))
        (if (listp (cdr (car marks)))
            (progn ; So a list containing filename, linenumber, ... like (grep) provides is used.
              (setq file (nth 1 (car marks)))
              (setq line (nth 2 (car marks)))

              (setq file (concat (car (cdr file))
                                 (car file)))

              ;; In case file contains an absolute path, the above doesn't work, at least not on Win32.  Use this version.
              ;; Originally suggested by: Markus Gritsch
              (if (not (file-exists-p file))
                  (setq file (car (nth 1 (car marks))))))

          (progn ; Otherwise we assume that we have a marker, which works also on buffers which have no file associated.
            (setq file (buffer-name (marker-buffer (cdr (car marks)))))

            (setq line (save-excursion
                         (set-buffer (marker-buffer (cdr (car marks))))
                         (save-excursion
                           (goto-char (cdr (car marks)))
                           (count-lines 1 (1+ (point))))))))

        ;; We've got the goods, lets add in an entry.
        ;; If we can't find the file, skip it.  It'll be
        ;; found eventually.
        (when (or (file-exists-p file) (bufferp (marker-buffer (cdr (car marks)))))

          (condition-case nil
              (save-excursion
                (set-buffer (marker-buffer errmark))
                (save-excursion
                  (goto-char errmark)
          
                  (setq face (cond
                              ((re-search-forward "error" (point-at-eol) t)
                               'linemark-stop-face)
                              ((re-search-forward "warning" (point-at-eol) t)
                               'linemark-caution-face)
                              (t
                               'linemark-go-face)))))
            (error nil))

          (condition-case nil
              (save-excursion
                (set-buffer (marker-buffer errmark))
                (save-excursion
                  (goto-char errmark)
                  (setq txt (buffer-substring-no-properties
                             (point-at-bol) (point-at-eol)))
                  ;; Strip positional information
                  (while (string-match "[0-9]:" txt)
                    (setq txt (substring txt (match-end 0))))
                  ;; Strip leading whitespace (if any)
                  (when (string-match "^\\s-++" txt)
                    (setq txt (substring txt (match-end 0))))
                  ))
            (error nil))

          (setq entry
                (linemark-add-entry
                 lmcompile-error-group
                 :filename file
                 :line line
                 :errormarker errmark
                 :face face
                 :errmsg txt
                 ))

          ))
      (setq marks (cdr marks)))))

(provide 'lmcompile)

;;; lmcompile.el ends here