[MLton-commit] r5712
Vesa Karvonen
vesak at mlton.org
Mon Jul 2 03:54:53 PDT 2007
Rudimentary highlighting of error sexps. Also a couple of Emacs
compatibility kludge fixes.
----------------------------------------------------------------------
U mlton/trunk/ide/emacs/bg-build-mode.el
U mlton/trunk/ide/emacs/bg-build-util.el
----------------------------------------------------------------------
Modified: mlton/trunk/ide/emacs/bg-build-mode.el
===================================================================
--- mlton/trunk/ide/emacs/bg-build-mode.el 2007-07-02 10:47:51 UTC (rev 5711)
+++ mlton/trunk/ide/emacs/bg-build-mode.el 2007-07-02 10:54:52 UTC (rev 5712)
@@ -9,7 +9,7 @@
;; This is a minor mode for ``handsfree'' background batch building. See
;; http://mlton.org/EmacsBgBuildMode for further information.
-;; XXX: Highlight (lines with) errors and warnings
+;; XXX: Cleanup.
;; XXX: Combinators for making common project configurations:
;; - E.g. grep for saved files from given file
;; XXX: Locate project file(s) automatically
@@ -80,6 +80,11 @@
:set (function bg-build-set-custom-and-update)
:group 'bg-build)
+(defcustom bg-build-highlighting-overlay-priority 500
+ "Priority of highlighting overlays."
+ :type 'integer
+ :group 'bg-build)
+
(defcustom bg-build-max-live-builds 1
"Maximum number of live build processes to run concurrently or nil for
unlimited."
@@ -88,6 +93,19 @@
(number :tag "Number"))
:group 'bg-build)
+(defface bg-build-message-sexp-face
+ '((((class color)) (:background "orange"))
+ (t (:background "gray")))
+ "Face for highlighting sexps that are referred to in messages."
+ :group 'faces
+ :group 'bg-build)
+
+(defcustom bg-build-message-highlighting '(sexp)
+ "How to highlight source locations corresponding to messages. Unselect
+all to disable highlighting."
+ :type '(set (const :tag "Sexp" sexp))
+ :group 'bg-build)
+
(defcustom bg-build-notify '(messages failure)
"When to notify about completed builds."
:type '(set (const :tag "Success" success)
@@ -157,7 +175,7 @@
(cond
((not file)
(bg-build-add-project
- (read-file-name
+ (compat-read-file-name
"Specify bg-build -file: " nil nil t nil 'bg-build-add-project-history)))
((not (and (file-readable-p file)
(file-regular-p file)))
@@ -197,16 +215,100 @@
(defun bg-build-parse-messages ()
(let ((original-display-message
- (symbol-function 'display-message)))
- (fset 'display-message
- (function
- (lambda (label &rest args)
- (unless (eq label 'progress)
- (apply original-display-message label args)))))
+ (when (fboundp 'display-message)
+ (symbol-function 'display-message))))
+ (when (fboundp 'display-message)
+ (fset 'display-message
+ (function
+ (lambda (label &rest args)
+ (unless (eq label 'progress)
+ (apply original-display-message label args))))))
(unwind-protect
(funcall compilation-parse-errors-function nil nil)
- (fset 'display-message original-display-message))))
+ (when (fboundp 'display-message)
+ (fset 'display-message original-display-message)))))
+;; XXX: The following advice depends on the internals of the compilation mode.
+(defadvice next-error (after bg-build-next-error activate)
+ (with-current-buffer compilation-last-buffer
+ (bg-build-highlight-messages)))
+
+(defadvice compile-goto-error (after bg-build-compile-goto-error activate)
+ (with-current-buffer compilation-last-buffer
+ (bg-build-highlight-messages)))
+
+(defvar bg-build-highlighting-overlays nil)
+
+(defun bg-build-parse-message (message)
+ (when (consp message)
+ (let ((marker (car message))
+ (message (cdr message)))
+ (cond
+ ((markerp message)
+ (let* ((buffer (marker-buffer message))
+ (file (buffer-file-name buffer))
+ (point (marker-position message))
+ (pos (bg-build-point-to-pos point)))
+ (cons file pos)))
+ ((consp message)
+ (cons (caar message)
+ (cons (cadr message)
+ (1- (or (caddr message) 1)))))))))
+
+(defun bg-build-delete-highlighting-overlays ()
+ (mapc (function
+ (lambda (maybe-overlay)
+ (when (overlayp maybe-overlay)
+ (delete-overlay maybe-overlay))))
+ bg-build-highlighting-overlays)
+ (setq bg-build-highlighting-overlays nil))
+
+(defun bg-build-highlight-messages ()
+ (when (and bg-build-messages
+ bg-build-message-highlighting)
+ (let ((file-to-buffer (bg-build-make-hash-table)))
+ (mapc (function
+ (lambda (buffer)
+ (puthash (buffer-file-name buffer)
+ buffer
+ file-to-buffer)))
+ (buffer-list))
+ (setq bg-build-highlighting-overlays
+ (mapcar (function
+ (lambda (info-or-overlay)
+ (if (overlayp info-or-overlay)
+ info-or-overlay
+ (let* ((info info-or-overlay)
+ (file (car info))
+ (pos (cdr info))
+ (buffer (gethash file file-to-buffer)))
+ (if (not buffer)
+ info-or-overlay
+ (with-current-buffer buffer
+ (let* ((begin
+ (bg-build-pos-to-point pos))
+ (beyond
+ (save-excursion
+ (goto-char begin)
+ (condition-case ()
+ (forward-sexp)
+ (error
+ (condition-case ()
+ (forward-word 1)
+ (error
+ ))))
+ (point)))
+ (overlay
+ (make-overlay begin beyond)))
+ (overlay-put
+ overlay 'priority
+ bg-build-highlighting-overlay-priority)
+ (overlay-put
+ overlay 'face
+ 'bg-build-message-sexp-face)
+ overlay)))))))
+ bg-build-highlighting-overlays)))))
+
(defun bg-build-process-sentinel (project)
(lexical-let ((project project))
(lambda (process event)
@@ -233,10 +335,16 @@
(bg-build-parse-messages)
(set (make-local-variable 'bg-build-messages)
(and (listp compilation-error-list)
- compilation-error-list))))
+ compilation-error-list))
+ (set (make-local-variable 'bg-build-highlighting-overlays)
+ (mapcar (function bg-build-parse-message)
+ bg-build-messages))))
(setq bg-build-live-builds
(bg-build-remove-from-assoc bg-build-live-builds file))
(bg-build-check-build-queue)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (bg-build-highlight-messages)))
(cond
((string-match "EXITED ABNORMALLY WITH CODE \\([^\n]+\\)\n" event)
(with-current-buffer buffer
@@ -246,8 +354,9 @@
(with-current-buffer buffer
(length bg-build-messages))
(bg-build-prj-name project))))
- ((and (with-current-buffer buffer
- bg-build-messages)
+ ((and (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ bg-build-messages))
(memq 'messages bg-build-notify)
(string-match "FINISHED\n" event))
(with-current-buffer buffer
@@ -266,6 +375,7 @@
(let ((file (car project)))
(setq bg-build-finished-builds
(bg-build-remove-from-assoc bg-build-finished-builds file)))
+ (bg-build-delete-highlighting-overlays)
(bg-build-status-update))))
(defvar bg-build-counter 0)
Modified: mlton/trunk/ide/emacs/bg-build-util.el
===================================================================
--- mlton/trunk/ide/emacs/bg-build-util.el 2007-07-02 10:47:51 UTC (rev 5711)
+++ mlton/trunk/ide/emacs/bg-build-util.el 2007-07-02 10:54:52 UTC (rev 5712)
@@ -72,6 +72,23 @@
(> (bg-build-time-to-double (nth 5 attr1))
(bg-build-time-to-double (nth 5 attr2)))))
+(defun bg-build-pos-to-point (pos)
+ "Returns the value of point in the current buffer at the position given
+as a (line . col) pair."
+ (save-excursion
+ (goto-line (car pos))
+ (+ (point) (cdr pos))))
+
+(defun bg-build-point-to-pos (point)
+ "Returns the position as a (line . col) pair corresponding to the
+specified point in the current buffer."
+ (save-excursion
+ (goto-char point)
+ (beginning-of-line)
+ (let ((line (+ (count-lines 1 (point)) 1))
+ (col (- point (point))))
+ (cons line col))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'bg-build-util)
More information about the MLton-commit
mailing list