emacs-config/lib/prog/jao-compilation.el

;;; jao-compilation.el --- utilities to lauch compilations  -*- lexical-binding: t; -*-

;; Copyright (C) 2020, 2021, 2022  jao

;; Author: jao <mail@jao.io>
;; Keywords: convenience

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Utilities to launch compilation processes from adequate root directories

;;; Code:

(defvar jao-compilation-dominating-files nil)
(defvar jao-compilation-dominating-file-rxs '(".+\\.cabal"))
(defvar jao-compilation-environment ())
(defvar jao-compilation-dominating-rx "")

(defun jao-compilation--environment ()
  (let (result)
    (dolist (v jao-compilation-environment result)
      (let ((vv (getenv v)))
        (when vv (add-to-list 'result (format "%s=%s" v vv)))))))

;;;###autoload
(defun jao-compilation-add-dominating (&rest fs)
  (dolist (f fs) (add-to-list 'jao-compilation-dominating-files f))
  (setq jao-compilation-dominating-rx
        (concat "\\("
                (regexp-opt jao-compilation-dominating-files)
                "\\|"
                (mapconcat 'identity
                           jao-compilation-dominating-file-rxs
                           "\\|")
                "\\)$")))

;;;###autoload
(defun jao-path-relative-to (path base)
  (let* ((path (file-name-directory path))
         (base (file-name-directory base))
         (blen (length base)))
    (if (<= (length path) blen)
        path
      (if (string-equal base (substring path 0 blen))
          (substring path blen)
        path))))

;;;###autoload
(defun jao-compilation-find-root (file doms)
  (when file
    (locate-dominating-file file `(lambda (d)
                                    (when (file-directory-p d)
                                      (directory-files d nil ,doms))))))

;;;###autoload
(defun jao-compilation-root (&optional dir)
  (when-let ((rfn (jao-compilation-find-root (or dir (buffer-file-name))
                                             jao-compilation-dominating-rx)))
    (let* ((default-directory (expand-file-name rfn))
           (dir (file-name-directory rfn))
           (rel-path (jao-path-relative-to dir default-directory)))
      (if (and (file-directory-p "build")
               (not (file-exists-p "build.xml"))
               (not (file-exists-p "setup.py")))
          (expand-file-name rel-path (expand-file-name "build/"))
        default-directory))))

;;;###autoload
(defun jao-compilation-root-file ()
  (when-let ((dir (jao-compilation-root)))
    (car (directory-files dir nil jao-compilation-dominating-rx))))

;;;###autoload
(defun jao-find-compilation-root (dir)
  (when (and (stringp dir) (file-exists-p dir))
    (when-let ((root (jao-compilation-root dir)))
      (cons 'transient root))))

;;;###autoload
(defun jao-compilation-env (v)
  "Add new environment variables to the compilation environment
        used by `jao-compile'"
  (add-to-list 'jao-compilation-environment v))

;;;###autoload
(defun jao-compile ()
  "Find the root of current file's project and issue a
        compilation command"
  (interactive)
  (let ((default-directory (or (jao-compilation-root) default-directory))
        (compilation-environment (jao-compilation--environment))
        (compilation-read-command 'compilation-read-command))
    (call-interactively 'compile)))

;;;###autoload
(defun jao-compilation-setup ()
  (jao-compilation-add-dominating
   "Makefile" "makefile" "configure.ac" "bootstrap.sh" "aclocal.m4"
   "project.clj" "build.xml" "pom.xml" "setup.py" "stack.yaml")
  (with-eval-after-load "project"
    (add-to-list 'project-find-functions #'jao-find-compilation-root t)))


(provide 'jao-compilation)
;;; jao-compilation.el ends here