1 ;; Copyright (C) 2007-2008 Vesa Karvonen
3 ;; MLton is released under a BSD-style license.
4 ;; See the file MLton-LICENSE for details.
7 (require 'bg-build-util
)
8 (if (string-match "XEmacs" emacs-version
)
11 ;; This is a minor mode for ``handsfree'' background batch building. See
12 ;; http://mlton.org/EmacsBgBuildMode for further information.
15 ;; XXX: Combinators for making common project configurations:
16 ;; - E.g. grep for saved files from given file
17 ;; XXX: Locate project file(s) automatically
18 ;; XXX: Context menu to the mode line indicator
19 ;; XXX: `mode-line-format' (XEmacs 21.4) support
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24 (defvar bg-build-load-time t
)
26 (defun bg-build-set-custom-and-update (sym val
)
27 (custom-set-default sym val
)
28 (unless bg-build-load-time
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 (defgroup bg-build nil
35 "A minor mode for ``handsfree'' background batch builds."
38 (defcustom bg-build-action-on-failure
(function first-error
)
39 "Optional action to perform when build fails."
41 (const :tag
"None" ,(function (lambda () nil
)))
42 (function :tag
"Action"))
45 (defcustom bg-build-action-on-messages
(function first-error
)
46 "Optional action to perform when build does not fail, but produces
47 messages (typically warnings)."
49 (const :tag
"None" ,(function (lambda () nil
)))
50 (function :tag
"Action"))
53 (defcustom bg-build-delay
1.0
54 "Idle time in seconds to delay before automatically starting a build
55 after a save or nil if you wish to disable automatic builds."
57 (const :tag
"disable" nil
)
58 (number :tag
"seconds"))
61 (defcustom bg-build-key-bindings
63 "Key bindings for the bg-build mode. The key specifications must be in
64 a format accepted by the function `define-key'. Hint: You might want to
65 type `M-x describe-function bg-build <TAB>' to see the available commands."
66 :type
'(repeat (cons :tag
"Key Binding"
68 (function :tag
"Command")))
69 :set
(function bg-build-set-custom-and-update
)
72 (defcustom bg-build-highlighting-overlay-priority
500
73 "Priority of highlighting overlays."
77 (defcustom bg-build-max-live-builds
1
78 "Maximum number of live build processes to run concurrently or nil for
81 (const :tag
"Unlimited" nil
)
82 (number :tag
"Number"))
85 (defface bg-build-message-sexp-face
86 '((((class color
)) (:background
"orange"))
87 (t (:background
"gray")))
88 "Face for highlighting sexps that are referred to in messages."
92 (defcustom bg-build-message-highlighting
'(sexp)
93 "How to highlight source locations corresponding to messages. Unselect
94 all to disable highlighting."
95 :type
'(set (const :tag
"Sexp" sexp
))
98 (defcustom bg-build-notify
'(messages failure
)
99 "When to notify about completed builds."
100 :type
'(set (const :tag
"Success" success
)
101 (const :tag
"Messages" messages
)
102 (const :tag
"Failure" failure
))
105 (defcustom bg-build-projects-auto-load nil
106 "Automatic loading of `bg-build-projects-recent' at startup."
108 (const :tag
"Disabled" nil
)
109 (const :tag
"Enabled" t
))
112 (defcustom bg-build-projects-recent
'()
113 "Automatically updated list of BGB files currently or previously loaded.
114 This customization variable is not usually manipulated directly by the
117 (file :tag
"BGB file" :must-match t
))
120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
123 (defun* bg-build-prj
(file &key name build? shell
)
124 "Creates a project object for bg-build."
127 (cond ((functionp name
)
130 (bg-build-const name
))
133 (file-name-nondirectory file
)))))
135 (cond ((functionp build?
)
138 (bg-build-const t
))))
140 (cond ((functionp shell
)
143 (bg-build-const shell
))
145 (bg-build-const (split-string shell
"[ \n\t]+")))
147 (compat-error "Shell command required!"))))
149 (file-attributes file
))))
151 (defun bg-build-call-prj (project fun
&rest args
)
152 (let* ((file (car project
))
153 (directory (file-name-directory file
)))
155 (setq default-directory directory
)
156 (apply (bg-build-assoc-cdr fun project
) args
))))
158 (defun bg-build-prj-name (project)
159 (bg-build-call-prj project
'name
))
161 (defun bg-build-prj-build?
(project saved-files
)
162 (bg-build-call-prj project
'build? saved-files
))
164 (defun bg-build-prj-shell (project)
165 (bg-build-call-prj project
'shell
))
167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
170 (defvar bg-build-projects nil
)
172 (defun bg-build-set-projects (projects &optional dont-save
)
173 (setq bg-build-projects projects
)
174 (when (and (not dont-save
)
175 bg-build-projects-auto-load
)
176 (customize-save-variable
177 'bg-build-projects-recent
178 (mapcar (function car
) projects
))))
180 (defvar bg-build-add-project-history nil
)
182 (add-to-list 'auto-mode-alist
'("\\.bgb$" . emacs-lisp-mode
))
184 (defun bg-build-add-project (&optional file dont-save
)
185 "Adds a project file to bg-build minor mode. This basically
186 reads and evaluates the first Emacs Lisp expression from specified file.
187 The expression should evaluate to a bg-build project object."
191 (bg-build-add-project
192 (compat-read-file-name
193 "Specify bg-build -file: " nil nil t nil
'bg-build-add-project-history
)
195 ((not (and (file-readable-p file
)
196 (file-regular-p file
)))
197 (compat-error "Specified file is not a regular readable file"))
199 (let* ((file (compat-abbreviate-file-name (file-truename file
)))
200 (directory (file-name-directory file
))
201 (data (with-temp-buffer
202 (buffer-disable-undo)
203 (insert-file-contents file
)
204 (setq default-directory directory
)
205 (goto-char (point-min))
209 (apply (function bg-build-prj
) ,file args
)))
210 ,(read (current-buffer)))))))
211 (bg-build-set-projects
212 (bg-build-replace-in-assoc bg-build-projects file data
)
214 (bg-build-status-update))))
216 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
219 (defvar bg-build-finished-builds nil
)
221 (defvar bg-build-live-builds nil
)
223 (defun bg-build-interrupt-build (project)
224 (let* ((file (car project
))
225 (proc (bg-build-assoc-cdr file bg-build-live-builds
)))
227 ((and proc
(compat-process-live-p proc
))
228 ;; Ok. We interrupt the build.
229 (interrupt-process proc
))
231 ;; Hmm... Shouldn't normally happen. The sentinel is supposed
232 ;; to remove the build from the live list, so probably something
233 ;; unexpected occurred in the sentinel.
234 (setq bg-build-live-builds
235 (bg-build-remove-from-assoc
238 (bg-build-check-build-queue)))
240 (defvar bg-build-messages nil
)
242 (defun bg-build-parse-messages ()
243 (let ((original-display-message
244 (when (fboundp 'display-message
)
245 (symbol-function 'display-message
))))
246 (when (fboundp 'display-message
)
247 (fset 'display-message
249 (lambda (label &rest args
)
250 (unless (eq label
'progress
)
251 (apply original-display-message label args
))))))
253 (compat-compilation-parse-errors)
254 (when (fboundp 'display-message
)
255 (fset 'display-message original-display-message
)))))
257 ;; XXX: The following advice depends on the internals of the compilation mode.
258 (defadvice next-error
(after bg-build-next-error activate
)
259 (with-current-buffer compilation-last-buffer
260 (bg-build-highlight-messages)))
262 (defadvice compile-goto-error
(after bg-build-compile-goto-error activate
)
263 (with-current-buffer compilation-last-buffer
264 (bg-build-highlight-messages)))
266 (defvar bg-build-highlighting-overlays nil
)
268 (defun bg-build-parse-message (message)
271 (let ((message (cdr message
)))
274 (let* ((buffer (marker-buffer message
))
275 (file (buffer-file-name buffer
))
276 (point (marker-position message
))
277 (pos (bg-build-point-to-pos point
)))
278 (list (cons file pos
))))
283 (1- (or (caddr message
) 1)))))))))
285 (list (cons (aref message
0)
286 (cons (aref message
1) (aref message
2)))))))
288 (defun bg-build-delete-highlighting-overlays ()
290 (lambda (maybe-overlay)
291 (when (overlayp maybe-overlay
)
292 (delete-overlay maybe-overlay
))))
293 bg-build-highlighting-overlays
)
294 (setq bg-build-highlighting-overlays nil
))
296 (defun bg-build-highlight-messages ()
297 (when (and bg-build-messages
298 bg-build-message-highlighting
)
299 (let ((file-to-buffer (bg-build-make-hash-table)))
302 (puthash (buffer-file-name buffer
)
306 (setq bg-build-highlighting-overlays
308 (lambda (info-or-overlay)
309 (if (overlayp info-or-overlay
)
311 (let* ((info info-or-overlay
)
314 (buffer (gethash file file-to-buffer
)))
317 (with-current-buffer buffer
319 (bg-build-pos-to-point pos
))
324 (sml-user-forward-sexp) ;; XXX
335 (make-overlay begin beyond
)))
338 bg-build-highlighting-overlay-priority
)
341 'bg-build-message-sexp-face
)
343 bg-build-highlighting-overlays
)))))
345 (defun bg-build-process-sentinel (project)
346 (lexical-let ((project project
))
347 (lambda (process event
)
348 (let ((event (upcase event
))
350 (buffer (process-buffer process
)))
351 (when (buffer-live-p buffer
)
352 (with-current-buffer buffer
354 (compat-add-local-hook
356 (bg-build-kill-buffer-hook project
))
357 (setq buffer-read-only nil
)
358 (let ((point (point)))
359 (goto-char (point-max))
362 (setq buffer-read-only t
)
363 (let ((previous (assoc file bg-build-finished-builds
)))
365 (kill-buffer (cdr previous
))))
366 (push (cons file buffer
)
367 bg-build-finished-builds
)
368 (bg-build-parse-messages)
369 (set (make-local-variable 'bg-build-messages
)
370 (or (and (boundp 'compilation-locs
)
371 (hash-table-p compilation-locs
)
376 (let* ((file (file-truename (caar value
)))
377 (lines (cddr value
)))
381 (let ((locs (cdr line
)))
394 (and (consp compilation-error-list
)
395 compilation-error-list
)))
396 (set (make-local-variable 'bg-build-highlighting-overlays
)
399 (mapcar (function bg-build-parse-message
)
400 bg-build-messages
)))))
401 (setq bg-build-live-builds
402 (bg-build-remove-from-assoc bg-build-live-builds file
))
403 (bg-build-check-build-queue)
404 (when (buffer-live-p buffer
)
405 (with-current-buffer buffer
406 (bg-build-highlight-messages)))
408 ((string-match "EXITED ABNORMALLY WITH CODE \\([^\n]+\\)\n" event
)
409 (with-current-buffer buffer
411 (funcall bg-build-action-on-failure
)
414 (when (memq 'failure bg-build-notify
)
415 (message "FAILED, %d MESSAGE(S): %s"
416 (with-current-buffer buffer
417 (length bg-build-messages
))
418 (bg-build-prj-name project
))))
419 ((and (when (buffer-live-p buffer
)
420 (with-current-buffer buffer
422 (memq 'messages bg-build-notify
)
423 (string-match "FINISHED\n" event
))
424 (with-current-buffer buffer
425 (funcall bg-build-action-on-messages
))
426 (message "%d MESSAGE(S): %s"
427 (with-current-buffer buffer
428 (length bg-build-messages
))
429 (bg-build-prj-name project
)))
430 ((and (memq 'success bg-build-notify
)
431 (string-match "FINISHED\n" event
))
432 (message "SUCCEEDED: %s" (bg-build-prj-name project
))))))))
434 (defun bg-build-kill-buffer-hook (project)
435 (lexical-let ((project project
))
437 (let ((file (car project
)))
438 (setq bg-build-finished-builds
439 (bg-build-remove-from-assoc bg-build-finished-builds file
)))
440 (bg-build-delete-highlighting-overlays)
441 (bg-build-status-update))))
443 (defvar bg-build-counter
0)
445 (defun bg-build-start-build (project)
446 (setq bg-build-counter
(1+ bg-build-counter
))
447 (let* ((file (car project
))
448 (directory (file-name-directory file
))
449 (name (format "*%s (bg-build: %d)*"
450 (bg-build-prj-name project
)
452 (shell (bg-build-prj-shell project
)))
453 (when (and name shell
)
454 (let* ((buffer (generate-new-buffer name
))
455 (process (with-current-buffer buffer
456 (buffer-disable-undo)
457 (compat-add-local-hook
459 (bg-build-kill-buffer-hook project
))
460 (insert "Compiling \"" file
"\":\n\n")
461 (setq buffer-read-only t
)
462 (setq default-directory directory
)
464 (function start-process-shell-command
)
468 (set-process-sentinel process
(bg-build-process-sentinel project
))
469 (push (cons file process
)
470 bg-build-live-builds
)))))
472 (defvar bg-build-build-queue nil
)
474 (defun bg-build-check-build-queue ()
475 (bg-build-status-update)
480 (when (and bg-build-build-queue
481 (or (not bg-build-max-live-builds
)
482 (< (length bg-build-live-builds
)
483 bg-build-max-live-builds
)))
484 (bg-build-start-build (car (last bg-build-build-queue
)))
485 (setq bg-build-build-queue
(butlast bg-build-build-queue
))
486 (bg-build-check-build-queue))))))
488 (defun bg-build-build-project (project)
489 (setq bg-build-build-queue
490 (bg-build-cons-once project bg-build-build-queue
))
491 (bg-build-interrupt-build project
))
493 (defun bg-build-switch-to-messages (&optional other-window
)
494 "Switches to the latest finished build buffer with messages."
496 (let ((builds bg-build-finished-builds
))
498 (not (with-current-buffer (cdar builds
)
502 (let ((buffer (cdar builds
)))
504 (switch-to-buffer-other-window buffer
)
505 (switch-to-buffer buffer
)))
506 (message "No messages"))))
508 (defun bg-build-switch-to-live (&optional other-window
)
509 "Switches to the latest live build buffer."
511 (if bg-build-live-builds
512 (let ((buffer (process-buffer (cdar bg-build-live-builds
))))
514 (switch-to-buffer-other-window buffer
)
515 (switch-to-buffer buffer
)))
516 (message "No live builds")))
518 (defun bg-build-switch-to-finished (&optional other-window
)
519 "Switches to the latest finished build buffer."
521 (if bg-build-finished-builds
522 (let ((buffer (cdar bg-build-finished-builds
)))
524 (switch-to-buffer-other-window buffer
)
525 (switch-to-buffer buffer
)))
526 (message "No finished builds")))
528 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
529 ;; Automatic Build Triggering
531 (defvar bg-build-saved-files nil
)
533 (defun bg-build-files-saved-timeout ()
537 (let ((file (car project
))
538 (data (cdr project
)))
539 (when (bg-build-attr-newer?
540 (file-attributes file
)
541 (bg-build-assoc-cdr 'attr data
))
542 (bg-build-add-project file t
)))))
544 (let ((saved-files bg-build-saved-files
))
545 (setq bg-build-saved-files nil
)
549 (when (bg-build-prj-build? project saved-files
)
550 (bg-build-build-project project
))))
553 (defvar bg-build-timer nil
)
555 (defun bg-build-delete-timer ()
557 (compat-delete-timer bg-build-timer
)
558 (setq bg-build-timer nil
)))
560 (defun bg-build-create-timer ()
561 (bg-build-delete-timer)
565 bg-build-delay nil
(function bg-build-files-saved-timeout
)))))
567 (defun bg-build-after-save-hook ()
568 (setq bg-build-saved-files
570 (compat-abbreviate-file-name (file-truename (buffer-file-name)))
571 bg-build-saved-files
))
572 (bg-build-create-timer))
574 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
577 (defconst bg-build-status-buffer-name
"<:Bg-Build Status:>")
579 (defconst bg-build-status-mode-map
580 (let ((result (make-sparse-keymap)))
582 (lambda (key-command)
584 (read (car key-command
))
586 `(("[(b)]" .
,(function bury-buffer
))
587 ("[(q)]" .
,(function bg-build-kill-current-buffer
))
588 ("[(a)]" .
,(function bg-build-add-project
))
589 ("[(r)]" .
,(function bg-build-status-rem-project
))
590 ("[(p)]" .
,(function bg-build-status-visit-project-file
))
591 ("[(f)]" .
,(function bg-build-status-visit-finished-build
))
592 ("[(l)]" .
,(function bg-build-status-visit-live-build
))
593 ("[(return)]" .
,(function bg-build-status-start-build
))))
596 (define-derived-mode bg-build-status-mode fundamental-mode
"Bg-Build-Status"
597 "Major mode for browsing bg-build related data."
598 :group
'bg-build-status
)
600 (defun bg-build-status ()
601 "Show a buffer with bg-build mode related data."
603 (let ((buffer (get-buffer-create bg-build-status-buffer-name
)))
604 (with-current-buffer buffer
605 (buffer-disable-undo)
606 (setq buffer-read-only t
)
607 (bg-build-status-mode))
608 (switch-to-buffer buffer
))
609 (bg-build-status-update))
611 (defvar bg-build-status
""
612 "Mode line status indicator for BGB mode")
614 (defun bg-build-status-update ()
615 (let ((buffer (get-buffer bg-build-status-buffer-name
)))
617 (with-current-buffer buffer
618 (let ((point (point)))
619 (setq buffer-read-only nil
)
621 (delete-char (buffer-size))
622 (insert "Status | Project
623 -------+------------------------------------------------------------------\n")
626 (let ((file (car project
)))
628 (let ((n (length (member project bg-build-build-queue
))))
629 (if (zerop n
) " " (format "%2d" n
)))
630 (if (assoc file bg-build-live-builds
) "L" " ")
633 file bg-build-finished-builds
)))
635 (with-current-buffer buffer
643 (bg-build-prj-name project
) " (" file
")"
646 (insert "\nTotal of " (number-to-string bg-build-counter
)
647 " builds started.\n")
648 (setq buffer-read-only t
)
649 (goto-char point
)))))
650 (setq bg-build-status
651 (labels ((fmt (label n
)
654 (t (format "%s%d" label n
)))))
655 (let* ((queued (fmt "Q" (length bg-build-build-queue
)))
656 (live (fmt "L" (length bg-build-live-builds
)))
661 (with-current-buffer (cdr build
)
662 (+ n
(length bg-build-messages
)))))
663 bg-build-finished-builds
665 (if (and (= 0 n
) bg-build-finished-builds
)
668 (str (concat "[" queued live messages
"] ")))
669 (if (string= str
"[] ")
673 (defun bg-build-status-the-project ()
674 (let ((idx (- (bg-build-current-line) 3)))
675 (when (and (<= 0 idx
)
676 (< idx
(length bg-build-projects
)))
677 (nth idx bg-build-projects
))))
679 (defun bg-build-status-rem-project ()
680 "Removes the project from bg-build."
682 (let ((project (bg-build-status-the-project)))
684 (bg-build-set-projects
685 (bg-build-remove-from-assoc bg-build-projects
(car project
)))
686 (bg-build-status-update))))
688 (defun bg-build-status-visit-project-file ()
689 "Visits the project file of the project."
691 (let ((project (bg-build-status-the-project)))
693 (find-file (car project
)))))
695 (defun bg-build-status-visit-finished-build ()
696 "Visits the buffer of the finished build of the project."
698 (let ((project (bg-build-status-the-project)))
700 (let ((build (assoc (car project
) bg-build-finished-builds
)))
702 (switch-to-buffer (cdr build
))
703 (message "That project has no finished builds."))))))
705 (defun bg-build-status-visit-live-build ()
706 "Visits the buffer of the live build of the project."
708 (let ((project (bg-build-status-the-project)))
710 (let ((build (assoc (car project
) bg-build-live-builds
)))
712 (switch-to-buffer (process-buffer (cdr build
)))
713 (message "That project has no live builds."))))))
715 (defun bg-build-status-start-build ()
716 "Starts a new build of the project."
718 (let ((project (bg-build-status-the-project)))
720 (bg-build-build-project project
))))
722 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
725 (defun bg-build-mode-enabled-in-some-buffer ()
726 (loop for buffer in
(buffer-list) do
727 (if (with-current-buffer buffer
731 (defvar bg-build-mode-map
(make-sparse-keymap)
732 "Keymap for Background-Build mode. This variable is updated by
733 `bg-build-build-mode-map'.")
735 (defun bg-build-build-mode-map ()
736 (let ((result (make-sparse-keymap)))
738 (lambda (key-command)
739 (define-key result
(read (car key-command
)) (cdr key-command
))))
740 bg-build-key-bindings
)
741 (setq bg-build-mode-map result
))
742 (let ((cons (assoc 'bg-build-mode minor-mode-map-alist
)))
744 (setcdr cons bg-build-mode-map
))))
746 (define-minor-mode bg-build-mode
747 "Minor mode for performing builds on the background.
749 \\{bg-build-mode-map}
754 'after-save-hook
(function bg-build-after-save-hook
))
755 (when (boundp 'mode-line-modes
)
756 (setq mode-line-modes
757 (remove '(t bg-build-status
) mode-line-modes
)))
758 (when (bg-build-mode-enabled-in-some-buffer)
761 (function bg-build-after-save-hook
))
762 (when (boundp 'mode-line-modes
)
763 (add-to-list 'mode-line-modes
'(t bg-build-status
)))))
765 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
768 (setq bg-build-load-time nil
)
770 (defun bg-build-update ()
771 "Update data based on customization variables."
772 (bg-build-build-mode-map))
780 (when bg-build-projects-auto-load
783 (when (and (file-readable-p file
)
784 (file-regular-p file
))
785 (bg-build-add-project file t
))))
786 bg-build-projects-recent
)))))
788 (provide 'bg-build-mode
)