[MLton-commit] r6787
Vesa Karvonen
vesak at mlton.org
Thu Aug 21 12:42:05 PDT 2008
Fixed to work with latest emacs snapshots. Also implemented a dynamically
updated mode line indicator.
----------------------------------------------------------------------
U mlton/trunk/ide/emacs/bg-build-mode.el
U mlton/trunk/ide/emacs/compat.el
----------------------------------------------------------------------
Modified: mlton/trunk/ide/emacs/bg-build-mode.el
===================================================================
--- mlton/trunk/ide/emacs/bg-build-mode.el 2008-08-21 17:16:07 UTC (rev 6786)
+++ mlton/trunk/ide/emacs/bg-build-mode.el 2008-08-21 19:42:04 UTC (rev 6787)
@@ -1,4 +1,4 @@
-;; Copyright (C) 2007 Vesa Karvonen
+;; Copyright (C) 2007-2008 Vesa Karvonen
;;
;; MLton is released under a BSD-style license.
;; See the file MLton-LICENSE for details.
@@ -13,6 +13,7 @@
;; XXX: Combinators for making common project configurations:
;; - E.g. grep for saved files from given file
;; XXX: Locate project file(s) automatically
+;; XXX: Context menu to the mode line indicator
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Prelude
@@ -190,6 +191,8 @@
(defvar bg-build-add-project-history nil)
+(add-to-list 'auto-mode-alist '("\\.bgb$" . emacs-lisp-mode))
+
(defun bg-build-add-project (&optional file dont-save)
"Adds a project file to bg-build minor mode. This basically
reads and evaluates the first Emacs Lisp expression from specified file.
@@ -233,7 +236,7 @@
(let* ((file (car project))
(proc (bg-build-assoc-cdr file bg-build-live-builds)))
(cond
- ((and proc (process-live-p proc))
+ ((and proc (compat-process-live-p proc))
;; Ok. We interrupt the build.
(interrupt-process proc))
(proc
@@ -259,7 +262,7 @@
(unless (eq label 'progress)
(apply original-display-message label args))))))
(unwind-protect
- (funcall compilation-parse-errors-function nil nil)
+ (compat-compilation-parse-errors)
(when (fboundp 'display-message)
(fset 'display-message original-display-message)))))
@@ -275,7 +278,8 @@
(defvar bg-build-highlighting-overlays nil)
(defun bg-build-parse-message (message)
- (when (consp message)
+ (cond
+ ((consp message)
(let ((message (cdr message)))
(cond
((markerp message)
@@ -283,11 +287,15 @@
(file (buffer-file-name buffer))
(point (marker-position message))
(pos (bg-build-point-to-pos point)))
- (cons file pos)))
+ (list (cons file pos))))
((consp message)
- (cons (caar message)
- (cons (cadr message)
- (1- (or (caddr message) 1)))))))))
+ (list
+ (cons (caar message)
+ (cons (cadr message)
+ (1- (or (caddr message) 1)))))))))
+ ((vectorp message)
+ (list (cons (aref message 0)
+ (cons (aref message 1) (aref message 2)))))))
(defun bg-build-delete-highlighting-overlays ()
(mapc (function
@@ -371,11 +379,36 @@
bg-build-finished-builds)
(bg-build-parse-messages)
(set (make-local-variable 'bg-build-messages)
- (and (listp compilation-error-list)
- compilation-error-list))
+ (or (and (hash-table-p compilation-locs)
+ (let ((entries nil))
+ (maphash
+ (function
+ (lambda (key value)
+ (let* ((file (file-truename (caar value)))
+ (lines (cddr value)))
+ (mapc
+ (function
+ (lambda (line)
+ (let ((locs (cdr line)))
+ (mapc
+ (function
+ (lambda (loc)
+ (push (vector
+ file
+ (or (cadr loc) 0)
+ (or (car loc) 0))
+ entries)))
+ locs))))
+ lines))))
+ compilation-locs)
+ entries))
+ (and (consp compilation-error-list)
+ compilation-error-list)))
(set (make-local-variable 'bg-build-highlighting-overlays)
- (mapcar (function bg-build-parse-message)
- bg-build-messages))))
+ (apply
+ (function append)
+ (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)
@@ -551,6 +584,10 @@
(switch-to-buffer buffer))
(bg-build-status-update))
+(defvar bg-build-status ""
+ "Mode line status indicator for BGB mode")
+(add-to-list 'mode-line-modes '(t bg-build-status))
+
(defun bg-build-status-update ()
(let ((buffer (get-buffer bg-build-status-buffer-name)))
(when buffer
@@ -586,7 +623,29 @@
(insert "\nTotal of " (number-to-string bg-build-counter)
" builds started.\n")
(setq buffer-read-only t)
- (goto-char point))))))
+ (goto-char point)))))
+ (setq bg-build-status
+ (labels ((fmt (label n)
+ (cond ((= n 0) "")
+ ((= n 1) label)
+ (t (format "%s%d" label n)))))
+ (let* ((queued (fmt "Q" (length bg-build-build-queue)))
+ (live (fmt "L" (length bg-build-live-builds)))
+ (messages
+ (let ((n (reduce
+ (function
+ (lambda (n build)
+ (with-current-buffer (cdr build)
+ (+ n (length bg-build-messages)))))
+ bg-build-finished-builds
+ :initial-value 0)))
+ (if (and (= 0 n) bg-build-finished-builds)
+ "F"
+ (fmt "M" n))))
+ (str (concat "[" queued live messages "] ")))
+ (if (string= str "[] ")
+ ""
+ str)))))
(defun bg-build-status-the-project ()
(let ((idx (- (bg-build-current-line) 3)))
@@ -666,7 +725,6 @@
\\{bg-build-mode-map}
"
- :lighter " BGB"
:group 'bg-build
:global t
(remove-hook
Modified: mlton/trunk/ide/emacs/compat.el
===================================================================
--- mlton/trunk/ide/emacs/compat.el 2008-08-21 17:16:07 UTC (rev 6786)
+++ mlton/trunk/ide/emacs/compat.el 2008-08-21 19:42:04 UTC (rev 6787)
@@ -1,4 +1,4 @@
-;; Copyright (C) 2007 Vesa Karvonen
+;; Copyright (C) 2007-2008 Vesa Karvonen
;;
;; MLton is released under a BSD-style license.
;; See the file MLton-LICENSE for details.
@@ -36,6 +36,18 @@
(defun compat-read-file-name (&optional a b c d e f)
(funcall (function read-file-name) a b c d e)))
+(if (string-match "XEmacs" emacs-version)
+ (defalias 'compat-process-live-p (function process-live-p))
+ (defun compat-process-live-p (process)
+ (case (process-status process)
+ ((run stop) t))))
+
+(if (string-match "XEmacs" emacs-version)
+ (defun compat-compilation-parse-errors ()
+ (funcall compilation-parse-errors-function nil nil))
+ (defun compat-compilation-parse-errors ()
+ (compilation-compat-parse-errors (point-max))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'compat)
More information about the MLton-commit
mailing list