| 1 | ;; Copyright (C) 2007-2008 Vesa Karvonen |
| 2 | ;; |
| 3 | ;; MLton is released under a BSD-style license. |
| 4 | ;; See the file MLton-LICENSE for details. |
| 5 | |
| 6 | (require 'compile) |
| 7 | (require 'bg-build-util) |
| 8 | (if (string-match "XEmacs" emacs-version) |
| 9 | (require 'overlay)) |
| 10 | |
| 11 | ;; This is a minor mode for ``handsfree'' background batch building. See |
| 12 | ;; http://mlton.org/EmacsBgBuildMode for further information. |
| 13 | |
| 14 | ;; XXX: Cleanup. |
| 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 |
| 20 | |
| 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 22 | ;; Prelude |
| 23 | |
| 24 | (defvar bg-build-load-time t) |
| 25 | |
| 26 | (defun bg-build-set-custom-and-update (sym val) |
| 27 | (custom-set-default sym val) |
| 28 | (unless bg-build-load-time |
| 29 | (bg-build-update))) |
| 30 | |
| 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 32 | ;; Customization |
| 33 | |
| 34 | (defgroup bg-build nil |
| 35 | "A minor mode for ``handsfree'' background batch builds." |
| 36 | :group 'compilation) |
| 37 | |
| 38 | (defcustom bg-build-action-on-failure (function first-error) |
| 39 | "Optional action to perform when build fails." |
| 40 | :type `(choice |
| 41 | (const :tag "None" ,(function (lambda () nil))) |
| 42 | (function :tag "Action")) |
| 43 | :group 'bg-build) |
| 44 | |
| 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)." |
| 48 | :type `(choice |
| 49 | (const :tag "None" ,(function (lambda () nil))) |
| 50 | (function :tag "Action")) |
| 51 | :group 'bg-build) |
| 52 | |
| 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." |
| 56 | :type '(choice |
| 57 | (const :tag "disable" nil) |
| 58 | (number :tag "seconds")) |
| 59 | :group 'bg-build) |
| 60 | |
| 61 | (defcustom bg-build-key-bindings |
| 62 | '() |
| 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" |
| 67 | (string :tag "Key") |
| 68 | (function :tag "Command"))) |
| 69 | :set (function bg-build-set-custom-and-update) |
| 70 | :group 'bg-build) |
| 71 | |
| 72 | (defcustom bg-build-highlighting-overlay-priority 500 |
| 73 | "Priority of highlighting overlays." |
| 74 | :type 'integer |
| 75 | :group 'bg-build) |
| 76 | |
| 77 | (defcustom bg-build-max-live-builds 1 |
| 78 | "Maximum number of live build processes to run concurrently or nil for |
| 79 | unlimited." |
| 80 | :type '(choice |
| 81 | (const :tag "Unlimited" nil) |
| 82 | (number :tag "Number")) |
| 83 | :group 'bg-build) |
| 84 | |
| 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." |
| 89 | :group 'faces |
| 90 | :group 'bg-build) |
| 91 | |
| 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)) |
| 96 | :group 'bg-build) |
| 97 | |
| 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)) |
| 103 | :group 'bg-build) |
| 104 | |
| 105 | (defcustom bg-build-projects-auto-load nil |
| 106 | "Automatic loading of `bg-build-projects-recent' at startup." |
| 107 | :type '(choice |
| 108 | (const :tag "Disabled" nil) |
| 109 | (const :tag "Enabled" t)) |
| 110 | :group 'bg-build) |
| 111 | |
| 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 |
| 115 | user." |
| 116 | :type '(repeat |
| 117 | (file :tag "BGB file" :must-match t)) |
| 118 | :group 'bg-build) |
| 119 | |
| 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 121 | ;; Project Object |
| 122 | |
| 123 | (defun* bg-build-prj (file &key name build? shell) |
| 124 | "Creates a project object for bg-build." |
| 125 | (list |
| 126 | (cons 'name |
| 127 | (cond ((functionp name) |
| 128 | name) |
| 129 | ((stringp name) |
| 130 | (bg-build-const name)) |
| 131 | (t |
| 132 | (bg-build-const |
| 133 | (file-name-nondirectory file))))) |
| 134 | (cons 'build? |
| 135 | (cond ((functionp build?) |
| 136 | build?) |
| 137 | (t |
| 138 | (bg-build-const t)))) |
| 139 | (cons 'shell |
| 140 | (cond ((functionp shell) |
| 141 | shell) |
| 142 | ((consp shell) |
| 143 | (bg-build-const shell)) |
| 144 | ((stringp shell) |
| 145 | (bg-build-const (split-string shell "[ \n\t]+"))) |
| 146 | (t |
| 147 | (compat-error "Shell command required!")))) |
| 148 | (cons 'attr |
| 149 | (file-attributes file)))) |
| 150 | |
| 151 | (defun bg-build-call-prj (project fun &rest args) |
| 152 | (let* ((file (car project)) |
| 153 | (directory (file-name-directory file))) |
| 154 | (with-temp-buffer |
| 155 | (setq default-directory directory) |
| 156 | (apply (bg-build-assoc-cdr fun project) args)))) |
| 157 | |
| 158 | (defun bg-build-prj-name (project) |
| 159 | (bg-build-call-prj project 'name)) |
| 160 | |
| 161 | (defun bg-build-prj-build? (project saved-files) |
| 162 | (bg-build-call-prj project 'build? saved-files)) |
| 163 | |
| 164 | (defun bg-build-prj-shell (project) |
| 165 | (bg-build-call-prj project 'shell)) |
| 166 | |
| 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 168 | ;; Active Projects |
| 169 | |
| 170 | (defvar bg-build-projects nil) |
| 171 | |
| 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)))) |
| 179 | |
| 180 | (defvar bg-build-add-project-history nil) |
| 181 | |
| 182 | (add-to-list 'auto-mode-alist '("\\.bgb$" . emacs-lisp-mode)) |
| 183 | |
| 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." |
| 188 | (interactive) |
| 189 | (cond |
| 190 | ((not file) |
| 191 | (bg-build-add-project |
| 192 | (compat-read-file-name |
| 193 | "Specify bg-build -file: " nil nil t nil 'bg-build-add-project-history) |
| 194 | dont-save)) |
| 195 | ((not (and (file-readable-p file) |
| 196 | (file-regular-p file))) |
| 197 | (compat-error "Specified file is not a regular readable file")) |
| 198 | (t |
| 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)) |
| 206 | (eval `(labels |
| 207 | ((bg-build |
| 208 | (&rest args) |
| 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) |
| 213 | dont-save)) |
| 214 | (bg-build-status-update)))) |
| 215 | |
| 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 217 | ;; Running Builds |
| 218 | |
| 219 | (defvar bg-build-finished-builds nil) |
| 220 | |
| 221 | (defvar bg-build-live-builds nil) |
| 222 | |
| 223 | (defun bg-build-interrupt-build (project) |
| 224 | (let* ((file (car project)) |
| 225 | (proc (bg-build-assoc-cdr file bg-build-live-builds))) |
| 226 | (cond |
| 227 | ((and proc (compat-process-live-p proc)) |
| 228 | ;; Ok. We interrupt the build. |
| 229 | (interrupt-process proc)) |
| 230 | (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 |
| 236 | bg-build-live-builds |
| 237 | file)))) |
| 238 | (bg-build-check-build-queue))) |
| 239 | |
| 240 | (defvar bg-build-messages nil) |
| 241 | |
| 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 |
| 248 | (function |
| 249 | (lambda (label &rest args) |
| 250 | (unless (eq label 'progress) |
| 251 | (apply original-display-message label args)))))) |
| 252 | (unwind-protect |
| 253 | (compat-compilation-parse-errors) |
| 254 | (when (fboundp 'display-message) |
| 255 | (fset 'display-message original-display-message))))) |
| 256 | |
| 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))) |
| 261 | |
| 262 | (defadvice compile-goto-error (after bg-build-compile-goto-error activate) |
| 263 | (with-current-buffer compilation-last-buffer |
| 264 | (bg-build-highlight-messages))) |
| 265 | |
| 266 | (defvar bg-build-highlighting-overlays nil) |
| 267 | |
| 268 | (defun bg-build-parse-message (message) |
| 269 | (cond |
| 270 | ((consp message) |
| 271 | (let ((message (cdr message))) |
| 272 | (cond |
| 273 | ((markerp 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)))) |
| 279 | ((consp message) |
| 280 | (list |
| 281 | (cons (caar message) |
| 282 | (cons (cadr message) |
| 283 | (1- (or (caddr message) 1))))))))) |
| 284 | ((vectorp message) |
| 285 | (list (cons (aref message 0) |
| 286 | (cons (aref message 1) (aref message 2))))))) |
| 287 | |
| 288 | (defun bg-build-delete-highlighting-overlays () |
| 289 | (mapc (function |
| 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)) |
| 295 | |
| 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))) |
| 300 | (mapc (function |
| 301 | (lambda (buffer) |
| 302 | (puthash (buffer-file-name buffer) |
| 303 | buffer |
| 304 | file-to-buffer))) |
| 305 | (buffer-list)) |
| 306 | (setq bg-build-highlighting-overlays |
| 307 | (mapcar (function |
| 308 | (lambda (info-or-overlay) |
| 309 | (if (overlayp info-or-overlay) |
| 310 | info-or-overlay |
| 311 | (let* ((info info-or-overlay) |
| 312 | (file (car info)) |
| 313 | (pos (cdr info)) |
| 314 | (buffer (gethash file file-to-buffer))) |
| 315 | (if (not buffer) |
| 316 | info-or-overlay |
| 317 | (with-current-buffer buffer |
| 318 | (let* ((begin |
| 319 | (bg-build-pos-to-point pos)) |
| 320 | (beyond |
| 321 | (save-excursion |
| 322 | (goto-char begin) |
| 323 | (condition-case () |
| 324 | (sml-user-forward-sexp) ;; XXX |
| 325 | (error |
| 326 | (condition-case () |
| 327 | (forward-sexp) |
| 328 | (error |
| 329 | (condition-case () |
| 330 | (forward-word 1) |
| 331 | (error |
| 332 | )))))) |
| 333 | (point))) |
| 334 | (overlay |
| 335 | (make-overlay begin beyond))) |
| 336 | (overlay-put |
| 337 | overlay 'priority |
| 338 | bg-build-highlighting-overlay-priority) |
| 339 | (overlay-put |
| 340 | overlay 'face |
| 341 | 'bg-build-message-sexp-face) |
| 342 | overlay))))))) |
| 343 | bg-build-highlighting-overlays))))) |
| 344 | |
| 345 | (defun bg-build-process-sentinel (project) |
| 346 | (lexical-let ((project project)) |
| 347 | (lambda (process event) |
| 348 | (let ((event (upcase event)) |
| 349 | (file (car project)) |
| 350 | (buffer (process-buffer process))) |
| 351 | (when (buffer-live-p buffer) |
| 352 | (with-current-buffer buffer |
| 353 | (compilation-mode) |
| 354 | (compat-add-local-hook |
| 355 | 'kill-buffer-hook |
| 356 | (bg-build-kill-buffer-hook project)) |
| 357 | (setq buffer-read-only nil) |
| 358 | (let ((point (point))) |
| 359 | (goto-char (point-max)) |
| 360 | (insert "\n" event) |
| 361 | (goto-char point)) |
| 362 | (setq buffer-read-only t) |
| 363 | (let ((previous (assoc file bg-build-finished-builds))) |
| 364 | (when previous |
| 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) |
| 372 | (let ((entries nil)) |
| 373 | (maphash |
| 374 | (function |
| 375 | (lambda (key value) |
| 376 | (let* ((file (file-truename (caar value))) |
| 377 | (lines (cddr value))) |
| 378 | (mapc |
| 379 | (function |
| 380 | (lambda (line) |
| 381 | (let ((locs (cdr line))) |
| 382 | (mapc |
| 383 | (function |
| 384 | (lambda (loc) |
| 385 | (push (vector |
| 386 | file |
| 387 | (or (cadr loc) 0) |
| 388 | (or (car loc) 0)) |
| 389 | entries))) |
| 390 | locs)))) |
| 391 | lines)))) |
| 392 | compilation-locs) |
| 393 | entries)) |
| 394 | (and (consp compilation-error-list) |
| 395 | compilation-error-list))) |
| 396 | (set (make-local-variable 'bg-build-highlighting-overlays) |
| 397 | (apply |
| 398 | (function append) |
| 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))) |
| 407 | (cond |
| 408 | ((string-match "EXITED ABNORMALLY WITH CODE \\([^\n]+\\)\n" event) |
| 409 | (with-current-buffer buffer |
| 410 | (condition-case () |
| 411 | (funcall bg-build-action-on-failure) |
| 412 | (error |
| 413 | ))) |
| 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 |
| 421 | bg-build-messages)) |
| 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)))))))) |
| 433 | |
| 434 | (defun bg-build-kill-buffer-hook (project) |
| 435 | (lexical-let ((project project)) |
| 436 | (lambda () |
| 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)))) |
| 442 | |
| 443 | (defvar bg-build-counter 0) |
| 444 | |
| 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) |
| 451 | bg-build-counter)) |
| 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 |
| 458 | 'kill-buffer-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) |
| 463 | (apply |
| 464 | (function start-process-shell-command) |
| 465 | name |
| 466 | buffer |
| 467 | shell)))) |
| 468 | (set-process-sentinel process (bg-build-process-sentinel project)) |
| 469 | (push (cons file process) |
| 470 | bg-build-live-builds))))) |
| 471 | |
| 472 | (defvar bg-build-build-queue nil) |
| 473 | |
| 474 | (defun bg-build-check-build-queue () |
| 475 | (bg-build-status-update) |
| 476 | (run-with-idle-timer |
| 477 | 0.01 nil |
| 478 | (function |
| 479 | (lambda () |
| 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)))))) |
| 487 | |
| 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)) |
| 492 | |
| 493 | (defun bg-build-switch-to-messages (&optional other-window) |
| 494 | "Switches to the latest finished build buffer with messages." |
| 495 | (interactive "P") |
| 496 | (let ((builds bg-build-finished-builds)) |
| 497 | (while (and builds |
| 498 | (not (with-current-buffer (cdar builds) |
| 499 | bg-build-messages))) |
| 500 | (pop builds)) |
| 501 | (if builds |
| 502 | (let ((buffer (cdar builds))) |
| 503 | (if other-window |
| 504 | (switch-to-buffer-other-window buffer) |
| 505 | (switch-to-buffer buffer))) |
| 506 | (message "No messages")))) |
| 507 | |
| 508 | (defun bg-build-switch-to-live (&optional other-window) |
| 509 | "Switches to the latest live build buffer." |
| 510 | (interactive "P") |
| 511 | (if bg-build-live-builds |
| 512 | (let ((buffer (process-buffer (cdar bg-build-live-builds)))) |
| 513 | (if other-window |
| 514 | (switch-to-buffer-other-window buffer) |
| 515 | (switch-to-buffer buffer))) |
| 516 | (message "No live builds"))) |
| 517 | |
| 518 | (defun bg-build-switch-to-finished (&optional other-window) |
| 519 | "Switches to the latest finished build buffer." |
| 520 | (interactive "P") |
| 521 | (if bg-build-finished-builds |
| 522 | (let ((buffer (cdar bg-build-finished-builds))) |
| 523 | (if other-window |
| 524 | (switch-to-buffer-other-window buffer) |
| 525 | (switch-to-buffer buffer))) |
| 526 | (message "No finished builds"))) |
| 527 | |
| 528 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 529 | ;; Automatic Build Triggering |
| 530 | |
| 531 | (defvar bg-build-saved-files nil) |
| 532 | |
| 533 | (defun bg-build-files-saved-timeout () |
| 534 | (mapc |
| 535 | (function |
| 536 | (lambda (project) |
| 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))))) |
| 543 | bg-build-projects) |
| 544 | (let ((saved-files bg-build-saved-files)) |
| 545 | (setq bg-build-saved-files nil) |
| 546 | (mapc |
| 547 | (function |
| 548 | (lambda (project) |
| 549 | (when (bg-build-prj-build? project saved-files) |
| 550 | (bg-build-build-project project)))) |
| 551 | bg-build-projects))) |
| 552 | |
| 553 | (defvar bg-build-timer nil) |
| 554 | |
| 555 | (defun bg-build-delete-timer () |
| 556 | (when bg-build-timer |
| 557 | (compat-delete-timer bg-build-timer) |
| 558 | (setq bg-build-timer nil))) |
| 559 | |
| 560 | (defun bg-build-create-timer () |
| 561 | (bg-build-delete-timer) |
| 562 | (when bg-build-delay |
| 563 | (setq bg-build-timer |
| 564 | (run-with-idle-timer |
| 565 | bg-build-delay nil (function bg-build-files-saved-timeout))))) |
| 566 | |
| 567 | (defun bg-build-after-save-hook () |
| 568 | (setq bg-build-saved-files |
| 569 | (bg-build-cons-once |
| 570 | (compat-abbreviate-file-name (file-truename (buffer-file-name))) |
| 571 | bg-build-saved-files)) |
| 572 | (bg-build-create-timer)) |
| 573 | |
| 574 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 575 | ;; Status Mode |
| 576 | |
| 577 | (defconst bg-build-status-buffer-name "<:Bg-Build Status:>") |
| 578 | |
| 579 | (defconst bg-build-status-mode-map |
| 580 | (let ((result (make-sparse-keymap))) |
| 581 | (mapc (function |
| 582 | (lambda (key-command) |
| 583 | (define-key result |
| 584 | (read (car key-command)) |
| 585 | (cdr 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)))) |
| 594 | result)) |
| 595 | |
| 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) |
| 599 | |
| 600 | (defun bg-build-status () |
| 601 | "Show a buffer with bg-build mode related data." |
| 602 | (interactive) |
| 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)) |
| 610 | |
| 611 | (defvar bg-build-status "" |
| 612 | "Mode line status indicator for BGB mode") |
| 613 | |
| 614 | (defun bg-build-status-update () |
| 615 | (let ((buffer (get-buffer bg-build-status-buffer-name))) |
| 616 | (when buffer |
| 617 | (with-current-buffer buffer |
| 618 | (let ((point (point))) |
| 619 | (setq buffer-read-only nil) |
| 620 | (goto-char 1) |
| 621 | (delete-char (buffer-size)) |
| 622 | (insert "Status | Project |
| 623 | -------+------------------------------------------------------------------\n") |
| 624 | (mapc (function |
| 625 | (lambda (project) |
| 626 | (let ((file (car project))) |
| 627 | (insert |
| 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" " ") |
| 631 | (let ((buffer |
| 632 | (bg-build-assoc-cdr |
| 633 | file bg-build-finished-builds))) |
| 634 | (cond ((and buffer |
| 635 | (with-current-buffer buffer |
| 636 | bg-build-messages)) |
| 637 | "FM") |
| 638 | (buffer |
| 639 | "F ") |
| 640 | (t |
| 641 | " "))) |
| 642 | " | " |
| 643 | (bg-build-prj-name project) " (" file ")" |
| 644 | "\n")))) |
| 645 | bg-build-projects) |
| 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) |
| 652 | (cond ((= n 0) "") |
| 653 | ((= n 1) label) |
| 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))) |
| 657 | (messages |
| 658 | (let ((n (reduce |
| 659 | (function |
| 660 | (lambda (n build) |
| 661 | (with-current-buffer (cdr build) |
| 662 | (+ n (length bg-build-messages))))) |
| 663 | bg-build-finished-builds |
| 664 | :initial-value 0))) |
| 665 | (if (and (= 0 n) bg-build-finished-builds) |
| 666 | "F" |
| 667 | (fmt "M" n)))) |
| 668 | (str (concat "[" queued live messages "] "))) |
| 669 | (if (string= str "[] ") |
| 670 | "" |
| 671 | str))))) |
| 672 | |
| 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)))) |
| 678 | |
| 679 | (defun bg-build-status-rem-project () |
| 680 | "Removes the project from bg-build." |
| 681 | (interactive) |
| 682 | (let ((project (bg-build-status-the-project))) |
| 683 | (when project |
| 684 | (bg-build-set-projects |
| 685 | (bg-build-remove-from-assoc bg-build-projects (car project))) |
| 686 | (bg-build-status-update)))) |
| 687 | |
| 688 | (defun bg-build-status-visit-project-file () |
| 689 | "Visits the project file of the project." |
| 690 | (interactive) |
| 691 | (let ((project (bg-build-status-the-project))) |
| 692 | (when project |
| 693 | (find-file (car project))))) |
| 694 | |
| 695 | (defun bg-build-status-visit-finished-build () |
| 696 | "Visits the buffer of the finished build of the project." |
| 697 | (interactive) |
| 698 | (let ((project (bg-build-status-the-project))) |
| 699 | (when project |
| 700 | (let ((build (assoc (car project) bg-build-finished-builds))) |
| 701 | (if build |
| 702 | (switch-to-buffer (cdr build)) |
| 703 | (message "That project has no finished builds.")))))) |
| 704 | |
| 705 | (defun bg-build-status-visit-live-build () |
| 706 | "Visits the buffer of the live build of the project." |
| 707 | (interactive) |
| 708 | (let ((project (bg-build-status-the-project))) |
| 709 | (when project |
| 710 | (let ((build (assoc (car project) bg-build-live-builds))) |
| 711 | (if build |
| 712 | (switch-to-buffer (process-buffer (cdr build))) |
| 713 | (message "That project has no live builds.")))))) |
| 714 | |
| 715 | (defun bg-build-status-start-build () |
| 716 | "Starts a new build of the project." |
| 717 | (interactive) |
| 718 | (let ((project (bg-build-status-the-project))) |
| 719 | (when project |
| 720 | (bg-build-build-project project)))) |
| 721 | |
| 722 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 723 | ;; Mode |
| 724 | |
| 725 | (defun bg-build-mode-enabled-in-some-buffer () |
| 726 | (loop for buffer in (buffer-list) do |
| 727 | (if (with-current-buffer buffer |
| 728 | bg-build-mode) |
| 729 | (return t)))) |
| 730 | |
| 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'.") |
| 734 | |
| 735 | (defun bg-build-build-mode-map () |
| 736 | (let ((result (make-sparse-keymap))) |
| 737 | (mapc (function |
| 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))) |
| 743 | (when cons |
| 744 | (setcdr cons bg-build-mode-map)))) |
| 745 | |
| 746 | (define-minor-mode bg-build-mode |
| 747 | "Minor mode for performing builds on the background. |
| 748 | |
| 749 | \\{bg-build-mode-map} |
| 750 | " |
| 751 | :group 'bg-build |
| 752 | :global t |
| 753 | (remove-hook |
| 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) |
| 759 | (add-hook |
| 760 | 'after-save-hook |
| 761 | (function bg-build-after-save-hook)) |
| 762 | (when (boundp 'mode-line-modes) |
| 763 | (add-to-list 'mode-line-modes '(t bg-build-status))))) |
| 764 | |
| 765 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 766 | ;; Finalization |
| 767 | |
| 768 | (setq bg-build-load-time nil) |
| 769 | |
| 770 | (defun bg-build-update () |
| 771 | "Update data based on customization variables." |
| 772 | (bg-build-build-mode-map)) |
| 773 | |
| 774 | (bg-build-update) |
| 775 | |
| 776 | (run-with-idle-timer |
| 777 | 1.0 nil |
| 778 | (function |
| 779 | (lambda () |
| 780 | (when bg-build-projects-auto-load |
| 781 | (mapc (function |
| 782 | (lambda (file) |
| 783 | (when (and (file-readable-p file) |
| 784 | (file-regular-p file)) |
| 785 | (bg-build-add-project file t)))) |
| 786 | bg-build-projects-recent))))) |
| 787 | |
| 788 | (provide 'bg-build-mode) |