[MLton-commit] r5704
Vesa Karvonen
vesak at mlton.org
Sun Jul 1 09:53:42 PDT 2007
Improved failure / messages reporting.
----------------------------------------------------------------------
U mlton/trunk/ide/emacs/bg-build-mode.el
----------------------------------------------------------------------
Modified: mlton/trunk/ide/emacs/bg-build-mode.el
===================================================================
--- mlton/trunk/ide/emacs/bg-build-mode.el 2007-07-01 16:26:24 UTC (rev 5703)
+++ mlton/trunk/ide/emacs/bg-build-mode.el 2007-07-01 16:53:41 UTC (rev 5704)
@@ -9,19 +9,9 @@
;; This is a minor mode for ``handsfree'' background batch building. See
;; http://mlton.org/EmacsBgBuildMode for further information.
-;; NOTE: This mode is not yet quite complete! Expect several crucial
-;; usability improvements in the near future.
-;;
-;; XXX: Commands: goto-last-build-buffer
-;; XXX: Better compilation-mode:
-;; - Give count of warnings and errors
-;; - Is there a supported way to just parse the error messages and
-;; access the results of the parse? If not, I'll probably have to
-;; write a new new compilation mode.
-;; - Highlighting in XEmacs
+;; XXX: Highlight (lines with) errors and warnings
;; XXX: Combinators for making common project configurations:
;; - E.g. grep for saved files from given file
-;; XXX: Highlight (lines with) errors and warnings
;; XXX: Locate project file(s) automatically
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -57,12 +47,20 @@
:group 'compilation)
(defcustom bg-build-action-on-failure (function first-error)
- "Optional action to perform on build failure."
+ "Optional action to perform when build fails."
:type '(choice
(const :tag "None" (function (lambda () nil)))
(function :tag "Action"))
:group 'bg-build)
+(defcustom bg-build-action-on-messages (function first-error)
+ "Optional action to perform when build does not fail, but produces
+messages (typically warnings)."
+ :type '(choice
+ (const :tag "None" (function (lambda () nil)))
+ (function :tag "Action"))
+ :group 'bg-build)
+
(defcustom bg-build-delay 1.0
"Idle time in seconds to delay before automatically starting a build
after a save or nil if you wish to disable automatic builds."
@@ -90,12 +88,11 @@
(number :tag "Number"))
:group 'bg-build)
-(defcustom bg-build-notify 'on-failure
+(defcustom bg-build-notify '(messages failure)
"When to notify about completed builds."
- :type '(choice
- (const :tag "Always" always)
- (const :tag "Never" never)
- (const :tag "On failure" on-failure))
+ :type '(set (const :tag "Success" success)
+ (const :tag "Messages" messages)
+ (const :tag "Failure" failure))
:group 'bg-build)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -196,6 +193,20 @@
(interrupt-process (cdr live)))
(bg-build-check-build-queue)))
+(defvar bg-build-messages nil)
+
+(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)))))
+ (unwind-protect
+ (funcall compilation-parse-errors-function nil nil)
+ (fset 'display-message original-display-message))))
+
(defun bg-build-process-sentinel (project)
(lexical-let ((project project))
(lambda (process event)
@@ -218,18 +229,36 @@
(when previous
(kill-buffer (cdr previous))))
(push (cons file buffer)
- bg-build-finished-builds)))
+ bg-build-finished-builds)
+ (bg-build-parse-messages)
+ (set (make-local-variable 'bg-build-messages)
+ (and (listp compilation-error-list)
+ compilation-error-list))))
(setq bg-build-live-builds
(bg-build-remove-from-assoc bg-build-live-builds file))
(bg-build-check-build-queue)
(cond
- ((and (memq bg-build-notify '(always))
+ ((string-match "EXITED ABNORMALLY WITH CODE \\([^\n]+\\)\n" event)
+ (with-current-buffer buffer
+ (funcall bg-build-action-on-failure))
+ (when (memq 'failure bg-build-notify)
+ (message "FAILED, %d MESSAGE(S): %s"
+ (with-current-buffer buffer
+ (length bg-build-messages))
+ (bg-build-prj-name project))))
+ ((and (with-current-buffer buffer
+ bg-build-messages)
+ (memq 'messages bg-build-notify)
(string-match "FINISHED\n" event))
- (message "SUCCEEDED: %s" (bg-build-prj-name project)))
- ((string-match "EXITED ABNORMALLY WITH CODE \\([^\n]+\\)\n" event)
- (funcall bg-build-action-on-failure)
- (when (memq bg-build-notify '(always on-failure))
- (message "FAILED: %s" (bg-build-prj-name project)))))))))
+ (with-current-buffer buffer
+ (funcall bg-build-action-on-messages))
+ (message "%d MESSAGE(S): %s"
+ (with-current-buffer buffer
+ (length bg-build-messages))
+ (bg-build-prj-name project)))
+ ((and (memq 'success bg-build-notify)
+ (string-match "FINISHED\n" event))
+ (message "SUCCEEDED: %s" (bg-build-prj-name project))))))))
(defun bg-build-kill-buffer-hook (project)
(lexical-let ((project project))
@@ -383,16 +412,26 @@
(mapc (function
(lambda (project)
(let ((file (car project)))
- (insert (let ((n (length (member project bg-build-build-queue))))
- (if (zerop n) " " (format "%2d" n)))
- (if (assoc file bg-build-live-builds) "L" " ")
- (if (assoc file bg-build-finished-builds) "F" " ")
- " | "
- (bg-build-prj-name project) " (" file ")"
- "\n"))))
+ (insert (let ((n (length (member project bg-build-build-queue))))
+ (if (zerop n) " " (format "%2d" n)))
+ (if (assoc file bg-build-live-builds) "L" " ")
+ (let ((buffer
+ (bg-build-assoc-cdr
+ file bg-build-finished-builds)))
+ (cond ((and buffer
+ (with-current-buffer buffer
+ bg-build-messages))
+ "FM")
+ (buffer
+ "F ")
+ (t
+ " ")))
+ " | "
+ (bg-build-prj-name project) " (" file ")"
+ "\n"))))
bg-build-projects)
- (insert "\n"
- "Total of " (number-to-string bg-build-counter) " builds started.\n")
+ (insert "\nTotal of " (number-to-string bg-build-counter)
+ " builds started.\n")
(setq buffer-read-only t)
(goto-char point))))))
More information about the MLton-commit
mailing list