;;;; jimb-compile.el --- front end for M-x compile that finds objdirs
;;;;
;;;; A front end for M-x compile that, when invoked from a source
;;;; file, switches to the object directory most recently used with
;;;; that source file, and then invokes M-x compile.

(defun jc-parent-or-nil (dir)
  "Return the parent directory of DIR, or nil if DIR is a root."
  (let ((parent (file-name-directory (directory-file-name dir))))
    (if (string= parent dir)
        nil
      parent)))

(defun jc-find-config-status (objdir)
  "Return the path of the config.status file for OBJDIR.
This is either in OBJDIR or one of its parents."
  (let ((dir objdir)
        config-status)
    (while dir
      (setq config-status (expand-file-name "config.status" dir))
      (if (file-exists-p config-status)
          (setq dir nil)
        (setq config-status nil
              dir (jc-parent-or-nil dir))))
    config-status))

(defun jc-config-status-srcdir (config-status)
  "Return the source directory of the config.status file CONFIG-STATUS.
If we can't figure it out, return nil."
  (save-current-buffer
    ;; We don't try to use an existing buffer visiting the
    ;; config.status file, because that results in distracting "File
    ;; has changed" questions that pop up whenever compilation happens
    ;; to finish, and about which the user has no idea why they're
    ;; being asked.  config.status files aren't very big, anyway.
    (set-buffer (generate-new-buffer config-status))
    (insert-file-contents config-status)
    (prog1
        (save-excursion
          (goto-char (point-min))
          (if (or (re-search-forward "^ac_given_srcdir=\\(.*\\)$" nil t)
                  (re-search-forward "^srcdir=['\"]\\(.*\\)['\"]$" nil t)
                  (re-search-forward "^srcdir=\\(.*\\)$" nil t))
              (file-name-as-directory (expand-file-name (match-string 1)))
            nil))
      (kill-buffer))))

(defvar jc-objdir-alist nil
  "Association list mapping source dirs to the most recent objdirs.
The source directories listed all contain 'configure' scripts; the
corresponding object directories contain 'config.status' scripts 
pointing to them.

This is populated by 'js-compilation-finish-function', which is added to
'compilation-finish-functions'.")

(defun jc-set-assoc (symbol key value)
  "Set KEY to VALUE in the association list which is the value of SYMBOL.
Compare keys using 'equal'."
  (let* ((alist (symbol-value symbol))
         (assoc (assoc key alist)))
    (if assoc (setcdr assoc value)
      (set symbol (cons (cons key value) alist)))))

(defun jc-compilation-finish-function (buffer status)
  (save-excursion
    (set-buffer buffer)
    (let ((config-status (jc-find-config-status default-directory)))
      (when config-status
        (let* ((config-status-dir (file-name-directory config-status))
               (config-status-srcdir (jc-config-status-srcdir config-status)))
          (if config-status-srcdir
              (jc-set-assoc 'jc-objdir-alist 
                            config-status-srcdir config-status-dir)))))))

(add-hook 'compilation-finish-functions 'jc-compilation-finish-function)

(defun jc-find-objdir (srcdir)
  "Find the object directory for SRCDIR, based on past use of M-x compile.
Return 'nil' if there is no plausible match.
This consults 'jc-objdir-alist'."
  (setq srcdir (expand-file-name srcdir))
  ;; Look for any parent of SRCDIR in jc-objdir-alist.
  (let ((alist jc-objdir-alist)
        src-parent obj-parent)
    (while alist
      (when (string-match (concat "^" (regexp-quote (caar alist))) srcdir)
        (setq src-parent (caar alist)
              obj-parent (cdar alist)
              alist nil))
      (setq alist (cdr alist)))
    (when src-parent
      ;; Since srcdir is a directory name (ending in '/'), this will
      ;; be, too.
      (expand-file-name (file-relative-name srcdir src-parent) obj-parent))))

(defun jc-compile ()
  "Like M-x compile, but choose a compilation directory based on past compiles.
Each time a compilation finishes, we record the object directory
and its associated source directory.  Then, running 'jc-compile'
in a source directory switches to the object directory most
recently used with that source directory, and does the
compilation there.
We identify the top of the object tree by looking for a
'config.status' file.  We use the directory containing the
'configure' script that generated that as the top of the source
tree.
If the current buffer's default directory contains a 'Makefile',
then we assume it is an object directory itself, and do the
compilation there."
  (interactive)
  (let ((objdir (if (file-exists-p "Makefile") nil
                  (jc-find-objdir default-directory))))
    (if (and objdir
             (file-directory-p objdir))
        (let ((default-directory objdir))
          (call-interactively 'compile))
      (call-interactively 'compile))))

(provide 'jimb-compile)