;;; builder.el --- Build a project and run it -*- lexical-binding: t; -*- ;;; Copyright (C) 2022 BTuin ;;; Version: 0.1 ;;; Package-Requires: ((emacs "28.1")) ;;; Homepage: https://gitlab.com/btuin2/builder ;; 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 . ;;; Commentary: ;;; This package provides functions to ease the use of build systems with Emacs. ;;; Code: (require 'project) (require 'json) (require 'cl-lib) ;; only used to get the current branch name to create the build dir (require 'vc-git) ;; Global variables (defgroup builder nil "Customizations for Builder." :version 2 :group 'tools) (defvar builder--infos (make-hash-table :test 'equal) "Hash table storing the informations about the build systems. The key is the build systemd ID, a (lowercase?) string corresponding to the name of the build system. For example, the key of CMake is \"cmake\". The value for each key is a plist with multiple keys. Those keys are symbols, and currently are `:compile', `:configure' and `:priority'. For `:compile' and `:configure', the attached values are also plists. Those plist, called instructions, have keys that are also symbols. Those symbols are: `:inside-directory': whether the instructions should be executed inside the build directory or inside its parent directory. `:function-modification': a function with two arguments, COMMAND and DIRECTORY. COMMAND, a string, is the command to execute inside a shell. Those functions exist because some build systems need to add arguments in different situations. For example, Meson needs the flag \"--reconfigure\" if it was already configured once before. At this level, `:function-modification' applies to every instructions. `:instructions': a list of instructions. This is the deepest level. Detailled below. An instruction is a plist containing a command, a name, and optionnaly some parameters. The values are: `:name': a string used to display when asking the user. `:command': a string, the command to execute in a shell. Before execution, it is formatted by the function `#'builder-format-command'. See its documentation for more informations. `:function-modification': see `:function-modification' detailled upwards. At this level, only applies to this instruction. `:priority' is an integer. It is used to change the display order when asking the user. Greater value means greater priority.") (defcustom builder-dir-name "build" "Default build directory name." :type 'string :version "28.1" :group 'builder) (defcustom builder-cache-file (locate-user-emacs-file "projects-builder") "Cache file. Currently unused." :type 'file :version "28.1" :group 'builder) (defcustom builder-enable-multiple-build-directories nil "Currently unused. If set to true, use one directory per build system configuration. For example, configuring CMake in debug mode will use the directory \"build-cmake-debug\"." :type 'boolean :safe t :version "29.1" :group 'builder) (defcustom builder-build-dir-name-function #'builder-get-build-dir-name-default "A function that return the name of the build directory." :type 'function :safe t :version "29.1" :group 'builder) (defvar builder-build-system-files '(("cmake" . "CMakeLists.txt") ("cmake-presets" . "CMakePresets.json") ("meson" . "meson.build") ("autotools". ("configure" "configure.ac")) ("make" . "Makefile") ("cargo" . "Cargo.toml") ("dune" . "dune-project"))) (define-key project-prefix-map "C" 'builder-configure) (define-key project-prefix-map "c" 'builder-compile) ;; General functions (cl-defun builder-compilation-buffer-name-function-creator (&key build-system-id name type) "Return a *function* which return the name of the compilation buffer. BUILD-SYSTEM-ID is the name of the build system (e.g. \"cmake\", \"make\"...). NAME is the type of build, such as \"debug\", \"release\"... TYPE is the type of command, such as \"compile\", \"configure\"..." (lambda (mode) (concat "*" (downcase mode) " " " <" (project-name (project-current)) "> " type build-system-id " " name "*"))) (defun builder-get-build-dir-name-default (&rest _) "Return the build dir name given by the customizable variable BUILD-DIR-NAME." (let ((build-dir-name (or builder-dir-name "build"))) build-dir-name)) (defun builder-get-build-dir-name-vc-branch (&rest _) "Return BUILD-DIR-NAME concatenated with the current branch. For example, if the project is set on the branch \"bugfix\", the returned name is \"build-bugfix\"." (let ((build-dir-name (or builder-dir-name "build")) (current-vc-backend (vc-responsible-backend "." t))) (concat build-dir-name "-" (cond ((string= current-vc-backend "Git") (car (vc-git-branches))) (t (message "Could not determine branch name from version control")))))) (defun builder-get-build-dir-name-with-build-configuration (configuration &rest _) "Return BUILD-DIR-NAME concatenated with CONFIGURATION (WARNING!!! BROKEN). WARNING!!! The implementation is actually completely broken, beacause the configuration and the compilation instructions need to have exactly the same name. This needs to be rethought. Maybe use a some kind of regex to get the name of the directory? Like \"build(\\-.+)?\"? Original documentation below. CONFIGURATION is the build system configuration. For example, if you want to build the project in release mode, the result will be \"build-release\". This is useful if you want to quickly switch between release and debug, as some build systems will need a complete recompilation." (let ((build-dir-name (or builder-dir-name "build"))) (concat build-dir-name "-" configuration))) (defun builder--get-build-dir-parent (&optional directory) "Return the absolute path of the build directory's parent. DIRECTORY is the parent of the build directory, relative to the project root or can an asbolute path. If nil, the project root is returned." (if directory (expand-file-name directory (project-root (project-current))) (project-root (project-current)))) (defun builder--get-build-dir-name-absolute (&optional directory) "Return the absolute path of the build directory. If set, DIRECTORY is the parent directory of the build dir. DIRECTORY is relative to the project root, or can be absolute." (expand-file-name (funcall builder-build-dir-name-function) (builder--get-build-dir-parent directory))) (defun builder--get-path-relative-to-project (directory) "Return DIRECTORY relative to the project root." (file-relative-name directory (project-root (project-current)))) (defun builder-reload-dir-locals-project () "Update buffer variables set by the file \"dir-locals.el\". Currently unused, was created to experiment with dir-locals.el to create project-local instructions." (interactive) (let ((dir (project-root (project-current))) (enable-local-variables t)) (dolist (buffer (buffer-list)) (with-current-buffer buffer (when (equal default-directory dir) (hack-dir-local-variables-non-file-buffer)))))) (defun builder--detect-build-systems-list (directory) "Return a list of detected build systems inside DIRECTORY. DIRECTORY is either absolute or relative to the root of the project." (let ((directory (builder--get-build-dir-parent directory)) (detected-build-systems (list))) (dolist (system-file-list builder-build-system-files) (dolist (system-file (ensure-list (cdr system-file-list))) (when (file-exists-p (expand-file-name system-file directory)) (cl-pushnew (car system-file-list) detected-build-systems :test #'equal)))) detected-build-systems)) (defun builder-detect-build-system (&optional directory) "Return the identifier of one detected and selected build system. The detection occurs inside DIRECTORY if set, otherwise at the root of the project. If there are multiple build systems, asks the user to select one. Return nil if no build system is detected." (let ((build-system-list (builder--detect-build-systems-list (or directory (builder--get-build-dir-parent))))) (cond ((zerop (length build-system-list)) nil) ((length= build-system-list 1) (message (car build-system-list))) (t (completing-read "Select build system: " build-system-list nil t))))) (cl-defun builder-add-build-system (&key build-system-id configure compile priority) "Add a build system to the hash table BUILDER--INFOS. BUILD-SYSTEM-ID is a string indentifying the build system. CONFIGURE is a plist containing the instructions for the configuration. COMPILE is a plist containing the instructions for the configuration. PRIORITY is an integer used to chose the display order of the build system" (let ((build-system-infos nil)) (setq build-system-infos (plist-put build-system-infos :configure configure)) (setq build-system-infos (plist-put build-system-infos :compile compile)) (setq build-system-infos (plist-put build-system-infos :priority (or priority 0))) (puthash build-system-id build-system-infos builder--infos))) (cl-defun builder-add-instruction (&key build-system-id type instruction) "Add an instruction to the global table. BUILD-SYSTEM-ID is the identifier of the build system (a string). TYPE is either :configure or :compile. INSTRUCTION is a plist with a key :name, a key :command and other optional keys." (let* ((build-infos (gethash build-system-id builder--infos)) (type-infos (plist-get build-infos type )) (instructions-list (plist-get type-infos :instructions))) (cl-pushnew instruction instructions-list :test (lambda (x y) (string-equal (plist-get x :name) (plist-get y :name)))) (setq build-infos (plist-put build-infos type (plist-put type-infos :instructions instructions-list))) (puthash build-system-id build-infos builder--infos))) (cl-defun builder-remove-instruction (&key build-system-id type name) "Remove an instruction from the global table. BUILD-SYSTEM-ID is the identifier of the build system (a string). TYPE is either :configure or :compile. NAME is the name of the instruction to remove." (let* ((build-infos (gethash build-system-id builder--infos)) (type-infos (plist-get build-infos type )) (instructions-list (plist-get type-infos :instructions))) (setq instructions-list (cl-remove-if (lambda (x) (string-equal (plist-get x :name) name)) instructions-list)) (setq build-infos (plist-put build-infos type (plist-put type-infos :instructions instructions-list))) (puthash build-system-id build-infos builder--infos))) (defun builder--get-instruction-priority (instruction) "Get the priority of an instruction. INSTRUCTION is a plist that may contain the key `:priority', linking to an integer. If the key is not present, the priority is 0." (let ((priority (plist-get instruction :priority))) (if priority priority 0))) (defun builder--compare-instructions-priority (x y) "Compare the priority of the instructions X and Y. Returns true if X has a lower priority than Y." (< (builder--get-instruction-priority x) (builder--get-instruction-priority y))) (defun builder--get-instruction-list (build-system-id instruction-type) "Return a list of instructions for the build system. BUILD-SYSTEM-ID is a string identifying the build system, such as \"cmake\" or \"meson\". INSTRUCTION-TYPE is a symbol, such as `:config' or `:compile'." (let* ((instructions ()) (build-system-data (gethash build-system-id builder--infos)) (global-instruction-type-data (plist-get build-system-data instruction-type))) (dolist (new-instruction (plist-get global-instruction-type-data :instructions)) (cl-pushnew (dolist (symbol '(:inside-directory :function-modification) new-instruction) (let ((value (plist-get global-instruction-type-data symbol))) (if (plist-member new-instruction symbol) new-instruction (setq new-instruction (plist-put new-instruction symbol value))))) instructions :test (lambda (x y) (string-equal (plist-get x :name) (plist-get y :name))))) ;; Not sure if the priority system actually works, nor if it is desirable... (sort instructions #'builder--compare-instructions-priority))) (defun builder--find-in-list-of-plist (plist-list value key) "In a list of plist, return the plist matching the value VALUE for the key KEY. PLIST-LIST is a list of plist, such as `((:name \"name1\" ...) (:name \"name2\"...))'" (cl-find value plist-list :test (lambda (str pl) (string-equal str (plist-get pl key))))) (defun builder--select-instruction (instruction-list message) "Ask the user to select an instruction from INSTRUCTION-LIST. INSTRUCTION-LIST is a list of plist, and the function displays the `:name' value of each plist to make the choice. It also displays the string MESSAGE to the user." (cond ((length= instruction-list 1) (plist-get (car instruction-list) :name)) ((length> instruction-list 1) (completing-read message (cl-map 'list (lambda (x) (plist-get x :name)) instruction-list))))) (defun builder-format-command (command &optional directory) "Format the string COMMAND by replacing format specifications. It uses the function `format-spec'. DIRECTORY is the parent of the build directory. There are multiple format specifications. `%b' is the build directory name, quotted with `shell-quote-argument'. `%n' is the number of processors (core) availables. Provided by the function `num-processors'. `%p' is the absolute path of the parent of the build directory, quotted with `shell-quote-argument' `%f' is the absolute path of the build directory, quotted with `shell-quote-argument' For example, if you want a \"make\" command that use all of your cores, you can use the string \"cmake -j%n\". If your processor has 4 cores, it will be transformed to \"cmake -j4\"." (format-spec (or command "") `((?b . ,(shell-quote-argument (funcall builder-build-dir-name-function))) (?n . ,(num-processors)) (?p . ,(shell-quote-argument (builder--get-build-dir-parent directory))) (?f . ,(shell-quote-argument (builder--get-build-dir-name-absolute directory)))))) (cl-defun builder--execute-command (&key instruction directory) "Execute the command from INSTRUCTION. INSTRUCTION is a plist with the key `:command', with a string command as a value. MESSAGE is displayed to the user when asked to confirm the command. DIRECTORY the parent of the build directory. MODIFICATION-FUNC is a function modifying the command." (let* ((build-dir-absolute-directory (builder--get-build-dir-name-absolute directory)) (formatted-command (builder-format-command (plist-get instruction :command) directory)) (work-directory nil) (inside-directory (plist-get instruction :inside-directory))) (when (not (file-directory-p build-dir-absolute-directory)) ;; Should we ask before creating the directory? (make-directory build-dir-absolute-directory)) (if inside-directory (setq work-directory build-dir-absolute-directory) (setq work-directory (builder--get-build-dir-parent directory))) (let ((default-directory work-directory)) (compile (read-string (concat (when inside-directory (concat "[in \"" (builder--get-path-relative-to-project work-directory) "\"] ")) "Command: ") (if (plist-get instruction :function-modification) (funcall (plist-get instruction :function-modification) formatted-command directory) formatted-command)))))) ;;;###autoload (defun builder-configure (&optional directory) "Configure the build system. The configuration of a build system is a step happening before compilation. Some \"build systems\", such as Autotools or CMake are not actually build systems. They are in reality build systems generator. Their goal is to create Makefiles (or equivalent), which will then be used to compile the project. During this phase, some options are set, such as whether the project is compiled in debug or release mode, which files need to be compiled, or compile-time values. This function detects which build systems are available at the project root, or at DIRECTORY if set. DIRECTORY is either absolute or relative to the project root. It then asks to select a build system, and finally to chose an available instruction from the build system." (interactive) (let* ((build-system-id (builder-detect-build-system directory)) (selected-name nil) (instruction-list (builder--get-instruction-list build-system-id :configure)) (instruction nil)) (if build-system-id (progn (setq selected-name (builder--select-instruction instruction-list (concat "Select type of configuration for " build-system-id ":"))) (setq instruction (builder--find-in-list-of-plist instruction-list selected-name :name)) (let ((compilation-buffer-name-function ;; How does this even work?? ;; Isn't lexical binding supposed to prevent that? (builder-compilation-buffer-name-function-creator :type "configure" :build-system-id build-system-id :name selected-name))) (builder--execute-command :instruction instruction :directory directory))) (message "No known build system detected")))) ;; Should builder-compile and builder-configure exists? ;; Should they be one function with one parameter? Why? Why not? ;; Arguements for keeping them separated: ;; - Can change one without affecting the other ;; - There is not a lot of logic inside anyway, would merging them be actually useful? ;; Arguments againts: ;; - Duplication of logic ;; - Creating a new one require to copy the code. For instance, projectile has 5 ;; relevant functions, configure, compile, package, install, test (and run, ;; but this is a special case). Keeping five copies of virtually the same ;; function seems a bad idea. ;;;###autoload (defun builder-compile (&optional directory) "Compile the project. This function detects which build systems are available at the project root, or at DIRECTORY if non-nil. It then asks to select a build system, and then to chose an available instruction from the build system." (interactive) (let* ((build-system-id (builder-detect-build-system directory)) (selected-name nil) (instruction-list (builder--get-instruction-list build-system-id :compile)) (instruction nil)) (if build-system-id (progn(setq selected-name (builder--select-instruction instruction-list (concat "Select type of compilation for " build-system-id ":"))) (setq instruction (builder--find-in-list-of-plist instruction-list selected-name :name)) (let ((compilation-buffer-name-function ;; How does this even work?? ;; Isn't lexical binding supposed to prevent that? (builder-compilation-buffer-name-function-creator :type "compile" :build-system-id build-system-id :name selected-name))) (builder--execute-command :instruction instruction :directory directory))) (message "No known build system detected")))) ;; Build system specific functions (cl-defun builder--meson-configure-modify-command (command directory) "If Meson is already configured, append \"--reconfigure\" to COMMAND. It checks in the build directory, the child of DIRECTORY, if the file \"meson-private\" exists. DIRECTORY is either absolute or relative to the project root." (let ((build-dir-absolute-name (builder--get-build-dir-name-absolute directory))) (if (file-directory-p (expand-file-name "meson-private" build-dir-absolute-name)) (concat command " --reconfigure") command))) (defun builder--cmake-presets-modify-command (command directory) "Ask the user to chose a preset from the file \"CMakePresets.json\". It appends \"--preset=PRESET\" to COMMAND, with PRESET being the selected preset. It looks for the file \"CmakePresets.json\" at DIRECTORY. DIRECTORY is either absolute or relative to the project root." (let ((cmake-presets-directory (expand-file-name "CMakePresets.json" (or directory (project-root (project-current))))) (selectioned-preset nil)) (setq selectioned-preset (when (and (json-available-p) (file-exists-p cmake-presets-directory)) (let ((presets-content (with-temp-buffer (insert-file-contents cmake-presets-directory) (goto-char (point-min)) (json-read))) (presets-table (make-hash-table))) (seq-doseq (preset-name (cdr (assoc 'configurePresets presets-content))) (puthash (cdr (assoc 'name preset-name)) (cdr (assoc 'displayName preset-name)) presets-table)) (when (not (hash-table-empty-p presets-table)) (completing-read "Select preset: " presets-table nil t))))) (if selectioned-preset (concat command " --preset=" selectioned-preset) (error "No preset selected")))) (defun builder--dune-modify-command-compile (command directory) "Ask user to chose a dune target. It recursively reads the dune files inside \"bin\" located inside DIRECTORY to find the name of the executable. Each dune file contains can contain at most one parameter \"executable\" xor (exclusive or) \"executables\". It then reads the value of the paramter \"name\" (resp. \"names\"). COMMAND is the command to modify. TODO: add a setting to change the directory, as \"bin\" may not be the right directory." (let* ((working-directory (builder--get-build-dir-parent directory)) (source-dir (expand-file-name "bin" working-directory)) (candidates ())) (dolist (dune-file (directory-files-recursively source-dir "^dune$")) (with-temp-buffer (insert "(progn ") (insert-file-contents dune-file) (goto-char (point-max)) (insert ")") (goto-char (point-min)) (let* ((content (cdr (read (current-buffer)))) (sexp nil) (res nil)) (while (and (setq sexp (caar content)) (not res)) (cond ((eq 'executable sexp) (cl-pushnew (file-relative-name (file-name-concat (file-name-parent-directory dune-file) (concat (symbol-name (car (alist-get 'name (cdar content)))) ".exe")) working-directory) candidates)) ((eq 'executables sexp) (setq candidates (append candidates (mapcar (lambda (name) (file-relative-name (file-name-concat (file-name-parent-directory dune-file) (concat name ".exe")) working-directory)) (mapcar #'symbol-name (alist-get 'names (cdar content)))))))) (setq content (cdr content)))))) (concat command (when candidates (let ((choice (shell-quote-argument (completing-read "Select target:" (cons "all" candidates) nil t)))) (if (not (string-equal "all" choice)) (concat " " choice))))))) ;; Add build systems (builder-add-build-system :build-system-id "cmake" :configure '(:inside-directory t :instructions ((:name "release" :command "cmake .. -DCMAKE_BUILD_TYPE=release -DCMAKE_EXPORT_COMPILE_COMMANDS=ON") (:name "debug" :command "cmake .. -DCMAKE_BUILD_TYPE=debug -DCMAKE_EXPORT_COMPILE_COMMANDS=ON"))) :compile '(:instructions ((:name "parallel" :command "cmake --build %b --parallel %n")))) (builder-add-build-system :build-system-id "meson" :configure '(:instructions ((:name "release" :command "meson setup %b --buildtype=release") (:name "debug" :command "meson setup %b --buildtype=debug")) :function-modification builder--meson-configure-modify-command) :compile '(:instructions ((:name "default" :command "meson compile -C %b")))) (builder-add-build-system :build-system-id "cmake-presets" :configure '(:instructions ((:name "default" :command "cmake")) :function-modification builder--cmake-presets-modify-command) :compile '(:instructions ((:name "parallel" :command "cmake --build %b --parallel %n")))) (builder-add-build-system :build-system-id "autotools" :configure '(:instructions ((:name "configure" :command "../configure" :inside-directory t) (:name "autoconf" :command "autoconf"))) :compile '(:instructions ((:name "parallel" :command "make -j%n")) :inside-directory t)) (builder-add-build-system :build-system-id "make" :compile '(:instructions ((:name "parallel" :command "make -j%n")))) (builder-add-build-system :build-system-id "cargo" :compile '(:instructions ((:name "release" :command "cargo build --release") (:name "debug" :command "cargo build")))) (builder-add-build-system :build-system-id "dune" :compile '(:instructions ((:name "compile" :command "dune build" :function-modification builder--dune-modify-command-compile)))) (provide 'builder) ;;; builder.el ends here