;;; ada-build.el --- Extensions to ada-mode for compiling and running  -*- lexical-binding:t -*-
;; Ada projects without 'make' or similar tool
;;
;; Copyright (C) 1994, 1995, 1997 - 2015  Free Software Foundation, Inc.
;;
;; Author: Stephen Leake <stephen_leake@member.fsf.org>
;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs 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.
;;
;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Design:
;;
;; Separate from ada-mode.el because sophisticated users don't need
;; this (they use 'make' or similar tool), so it would just get in the
;; way, particularly for fixing bugs in the core capabilities of
;; ada-mode.

;;; History:
;;
;; see ada-mode.el; the current code is a complete rewrite of the
;; compiling and running capabilities in Ada mode 4.01, done in 2013 by
;; Stephen Leake <stephen_leake@stephe-leake.org>.

(when (and (= emacs-major-version 24)
	   (= emacs-minor-version 2))
  (require 'ada-mode-compat-24.2))

(require 'ada-mode)

;;;; User customization

(defgroup ada-build nil
  "Major mode for compiling and running Ada projects in Emacs."
  :group 'ada)

(defcustom ada-build-prompt-prj 'default
  "Policy for finding a project file when none is currently selected."
  :type '(choice (const default)
		 (const prompt-default)
		 (const prompt-exist)
		 (const error))
  :safe  #'symbolp)

(defcustom ada-build-confirm-command nil
  "If non-nil, prompt for confirmation/edit of each command before it is run."
  :type  'boolean
  :safe  #'booleanp)

(defcustom ada-build-check-cmd
  (concat "${cross_prefix}gnatmake -u -c -gnatc ${gnatmake_opt} ${full_current} -cargs -I${src_dir} ${comp_opt}")
  "Default command to syntax check a single file.
Overridden by project variable 'check_cmd'."
  :type 'string)

(defcustom ada-build-make-cmd
  (concat "${cross_prefix}gnatmake -P${gpr_file} -o ${main} ${main} ${gnatmake_opt} "
	  "-cargs -I${src_dir} ${comp_opt} -bargs ${bind_opt} -largs ${link_opt}")
  "Default command to compile the application.
Overridden by project variable 'make_cmd'."
  :type 'string)

(defcustom ada-build-run-cmd "./${main}"
  "Default command to run the application, in a spawned shell.
Overridden by project variable 'run_cmd'."
  :type 'string)

;;;; code

(defun ada-build-replace-vars (cmd-string)
  "Recursively expand variable references in CMD-STRING.
${var} is a project variable or environment variable, $var an
environment variable.

A prefix may be specified with the format '-<prefix>${var}'; then
the value is expanded with the prefix prepended. If the value is
a list, the prefix is prepended to each list element. For
example, if src_dir contains 'dir_1 dir_2', '-I${src_dir}'
expands to '-Idir_1 -Idir_2'.

As a special case, ${full_current} is replaced by the name
including the directory and extension."

  (while (string-match "\\(-[^-$ ]+\\)?\\${\\([^}]+\\)}" cmd-string)
    (let ((prefix (match-string 1 cmd-string))
	  (name (match-string 2 cmd-string))
	  value)

      (when (string= name "full_current")
	(setq value (buffer-file-name)))

      (when (null value)
	(setq value (ada-prj-get (intern name))))

      (when (null value)
	(setq value (getenv name)))

      (cond
       ((null value)
	(setq cmd-string (replace-match "" t t cmd-string)))

       ((stringp value)
	(setq cmd-string (replace-match (concat prefix value) t t cmd-string)))

       ((listp value)
	(setq cmd-string (replace-match
			  (mapconcat (lambda (x) (concat prefix x)) value " ")
			    t t cmd-string)))
       )))

  (substitute-in-file-name cmd-string))

(defun ada-build-default-prj (project)
  "Add to PROJECT the default properties list for Ada project variables used by ada-build."
  (append
   project
   (list
    'check_cmd       ada-build-check-cmd
    'main            (when (buffer-file-name)
		       (file-name-nondirectory
			(file-name-sans-extension (buffer-file-name))))
    'make_cmd        ada-build-make-cmd
    'run_cmd         ada-build-run-cmd
    )))

(defun ada-build-select-default-prj ()
  "Create and select a new default project."
  (let ((prj-file (expand-file-name "default.adp"))
	project)

    (when (null (assoc prj-file ada-prj-alist))
      (setq project (ada-prj-default)) ;; ada-build-default-prj included via ada-prj-default-compiler-alist

      (add-to-list 'ada-prj-alist (cons prj-file project))
      )

    (ada-select-prj-file prj-file)
  ))

(defun ada-build-find-select-prj-file ()
  "Search for a project file in the current directory, parse and select it.
The file must have the same basename as the project variable
'main' or the current buffer if 'main' is nil, and extension from
`ada-prj-file-extensions'.  Returns non-nil if a file is
selected, nil otherwise."
  (let* ((base-file-name (file-name-base
			  (or (ada-prj-get 'main)
			      (file-name-nondirectory (file-name-sans-extension (buffer-file-name))))))
	 (filename
	  (or
	   (file-name-completion base-file-name
				 ""
				 (lambda (name) (member (file-name-extension name) ada-prj-file-extensions)))

	   (file-name-completion base-file-name
				 ""
				 (lambda (name) (member (file-name-extension name) ada-prj-file-ext-extra)))))
	)
    (when filename
      (ada-parse-prj-file filename)
      (ada-select-prj-file filename))
    ))

(defun ada-build-prompt-select-prj-file ()
  "Search for a project file, parse and select it.
The file must have an extension from `ada-prj-file-extensions'.
Returns non-nil if a file is selected, nil otherwise."
  (interactive)
  (let ((ext (append ada-prj-file-extensions ada-prj-file-ext-extra))
	filename)
    (condition-case nil
	(setq filename
	      (read-file-name
	       "Project file: " ; prompt
	       nil ; dir
	       "" ; default-filename
	       t   ; mustmatch
	       nil; initial
	       (lambda (name)
		 ;; this allows directories, which enables navigating
		 ;; to the desired file. We just assume the user won't
		 ;; return a directory.
		 (or (file-accessible-directory-p name)
		     (member (file-name-extension name) ext)))))
      (error
       (setq filename nil))
      )

    (when (not (equal "" filename))
      (ada-parse-prj-file filename)
      (ada-select-prj-file filename)
      t)
    ))

(defun ada-build-require-project-file ()
  "Ensure that a project file is selected.
Action when no project file is currently selected is determined
by `ada-build-prompt-prj':

default - Search for a project file in the current directory with
the same name as the main file. If not found, use a default
project; no gpr file, current directory only, current file as
main.

default-prompt - Search for a project file in the current
directory with the same name as the main file. If not found,
prompt for a project file; error result does not change current
project.

prompt - Prompt for a project file; error result does not
change current project.

error - Throw an error (no prompt, no default project)."
  (unless ada-prj-current-file
    (cl-ecase ada-build-prompt-prj
      (default
	(or (ada-build-find-select-prj-file)
	    (ada-build-select-default-prj)))

      (default-prompt
	(or (ada-build-find-select-prj-file)
	    (ada-build-prompt-select-prj-file)))

      (prompt
       (ada-build-prompt-select-prj-file))

      (error
       (error "no project file selected"))
      )))

;;;; user functions

(defun ada-build-run-cmd (prj-field confirm prompt)
  "Run the command in the PRJ-FIELD project variable.
If CONFIRM or `ada-build-confirm-command' are non-nil, ask for
user confirmation of the command, using PROMPT."
  (ada-build-require-project-file)
  (let ((cmd (ada-prj-get prj-field))
	(process-environment (ada-prj-get 'proc_env)))

    (unless cmd
      (setq cmd '("")
	    confirm t))

    (when (or ada-build-confirm-command confirm)
      (setq cmd (read-from-minibuffer (concat prompt ": ") cmd)))

    (compile (ada-build-replace-vars cmd))))

(defun ada-build-check (&optional confirm)
  "Run the check_cmd project variable.
By default, this checks the current file for syntax errors.
If CONFIRM is non-nil, prompt for user confirmation of the command."
  (interactive "P")
  (ada-build-run-cmd 'check_cmd confirm "check command"))

(defun ada-build-make (&optional confirm)
  "Run the make_cmd project variable.
By default, this compiles and links the main program.
If CONFIRM is non-nil, prompt for user confirmation of the command."
  (interactive "P")
  (ada-build-run-cmd 'make_cmd confirm "make command"))

(defun ada-build-set-make (&optional confirm)
  "Set the main project variable to the current file, then run the make_cmd project variable.
By default, this compiles and links the new main program.
If CONFIRM is non-nil, prompt for user confirmation of the command."
  (interactive "P")
  (ada-prj-put 'main (file-name-nondirectory (file-name-sans-extension (buffer-file-name))))
  (ada-build-run-cmd 'make_cmd confirm "make command"))

(defun ada-build-run (&optional confirm)
  "Run the run_cmd project variable.
By default, this runs the main program.
If CONFIRM is non-nil, prompt for user confirmation of the command."
  (interactive "P")
  (ada-build-run-cmd 'run_cmd confirm "run command"))

(defun ada-build-show-main ()
  "Show current project main program filename."
  (interactive)
  (message "Ada mode main: %s"(ada-prj-get 'main)))

;;; setup
(add-to-list 'ada-prj-default-list 'ada-build-default-prj)

(provide 'ada-build)
;; end of file