;;; project.el --- Operations on the current project  -*- lexical-binding: t; -*-

;; Copyright (C) 2015 Free Software Foundation, Inc.

;; 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/>.

;;; Commentary:

;; This file contains generic infrastructure for dealing with
;; projects, and a number of public functions: finding the current
;; root, related project directories, search path, etc.
;;
;; The goal is to make it easy for Lisp programs to operate on the
;; current project, without having to know which package handles
;; detection of that project type, parsing its config files, etc.

;;; Code:

(require 'cl-generic)

(defvar project-find-functions (list #'project-try-vc
                                     #'project-ask-user)
  "Special hook to find the project containing a given directory.
Each functions on this hook is called in turn with one
argument (the directory) and should return either nil to mean
that it is not applicable, or a project instance.")

(declare-function etags-search-path "etags" ())

(defvar project-search-path-function #'etags-search-path
  "Function that returns a list of source root directories.

The directories in which we can recursively look for the
declarations or other references to the symbols used in the
current buffer.  Depending on the language, it should include the
headers search path, load path, class path, or so on.

The directory names should be absolute.  This variable is
normally set by the major mode.  Used in the default
implementation of `project-search-path'.")

;;;###autoload
(defun project-current (&optional dir)
  "Return the project instance in DIR or `default-directory'."
  (unless dir (setq dir default-directory))
  (run-hook-with-args-until-success 'project-find-functions dir))

;; FIXME: Add MODE argument, like in `ede-source-paths'?
(cl-defgeneric project-search-path (project)
  "Return the list of source root directories.
Any directory roots where source (or header, etc) files used by
the current project may be found, inside or outside of the
current project tree(s).  The directory names should be absolute.

Unless it really knows better, a specialized implementation
should take into account the value returned by
`project-search-path-function' and call
`project-prune-directories' on the result."
  (project-prune-directories
   (append
    ;; We don't know the project layout, like where the sources are,
    ;; so we simply include the roots.
    (project-roots project)
    (funcall project-search-path-function))))

;; Conversion between recursive and flat paths.
(defun project--directory-directories-1 (dir ignore-regexp)
  "Return a list of all directories in DIR (non-recursively).
Ignores directories that match IGNORE-REGEXP (a regular expression).
DIR must not end in ?/."
  (let ((dirs (directory-files dir t nil t))
	(dir-dot (concat dir "/."))
	(dir-dotdot (concat dir "/.."))
	result)
    (while dirs
      (let ((dir1 (pop dirs)))
	(when (file-directory-p dir1)
	  (unless (or
		   (string= dir-dot dir1)
		   (string= dir-dotdot dir1)
		   (and ignore-regexp
			(string-match ignore-regexp dir1)))
	    (push dir1 result)))))
    result))


(defun project--directory-directories-recurse (dir ignore-regexp)
  "Return a list of all directories in DIR, recursively.
Ignores directories that match IGNORE-REGEXP (a regular expression).
DIR must not end in ?/."
  (let ((dirs (project--directory-directories-1 dir ignore-regexp))
	result dir)
    (while dirs
      (setq dir (pop dirs))
      (push dir result)
      (setq result (append (project--directory-directories-recurse dir ignore-regexp) result)))

    result))

(defun project-recursive-ignores-to-flat (recursive-path ignore-dirs)
  "Return a flat path constructed from RECURSIVE-PATH and IGNORE-DIRS."
  (let ((dirs recursive-path)
	(ignore-regexp (regexp-opt ignore-dirs))
	result dir)

    (while dirs
      (setq dir (pop dirs))
      (push dir result)
      (setq result (append (project--directory-directories-recurse (directory-file-name dir) ignore-regexp) result)))

    result))

(defun project-flat-to-recursive-ignores (flat-path)
  "Return a cons (RECURSIVE-PATH . IGNORE-DIRS) computed from FLAT-PATH."
  (let* ((dirs (mapcar
                 (lambda (dir)
                   (file-name-as-directory (expand-file-name dir)))
                 flat-path))
	 search-path
	 include-dirs
	 ignore-dirs
	 root)

    ;; FIXME: combine with above loop?
    (cl-delete-if-not #'file-exists-p dirs)

    ;; Recursively delete subdirectories under a parent that is also
    ;; in dirs. Add remaining to search-path, add unmentioned dirs to
    ;; ignores.
    ;;
    ;; Start by sorting by name, so the roots that are
    ;; present are just before their children.
    (setq dirs (sort dirs (lambda (a b) (string< a b))))

    (while (setq root (pop dirs))
      (setq include-dirs nil)
      (while (string-prefix-p root (car dirs))
	(push (pop dirs) include-dirs))
      (push root search-path)
      (dolist (subdir (directory-files root t))
	(when (file-directory-p subdir)
	  (unless (or
		   (string= (substring subdir -1) ".")
		   (string= (substring subdir -2) "..")
		   (member (file-name-as-directory subdir) include-dirs))
	    (push (file-name-as-directory subdir) ignore-dirs)))))

    (cons search-path ignore-dirs)
    ))

(cl-defgeneric project-ignore-dirs (_prj)
  "Return list of absolute directory names that should be ignored.
The names should be matched to directories when searching in
`project-search-path'."
  nil)

(cl-defgeneric project-flat-search-path (prj)
  "Return a flat search path for PRJ."
  (project-recursive-ignores-to-flat (project-search-path prj) (project-ignore-dirs prj)))

(cl-defgeneric project-roots (project)
  "Return the list of directory roots related to the current project.
It should include the current project root, as well as the roots
of any other currently open projects, if they're meant to be
edited together.  The directory names should be absolute.")

(cl-defgeneric project-ignores (_project _dir)
  ;; FIXME: do we need both project-ignores and project-ignore-files-globs?
  "Return the list of glob patterns to ignore inside DIR.
Patterns can match both regular files and directories.
To root an entry, start it with `./'.  To match directories only,
end it with `/'.  DIR must be either one of `project-roots', or
an element of `project-search-path'."
  (require 'grep)
  (defvar grep-find-ignored-files)
  (nconc
   (mapcar
    (lambda (dir)
      (concat dir "/"))
    vc-directory-exclusion-list)
   grep-find-ignored-files))

(cl-defgeneric project-ignore-files-globs (_prj)
  "Return list of file glob patterns that should be ignored in all directories.
The globs should be matched to file and directory names sans path
when searching in `project-search-path'."
  (require 'grep)
  (defvar grep-find-ignored-files)
  (append
    vc-directory-exclusion-list ;; preloaded
    grep-find-ignored-files))

(cl-defgeneric project-ignore-files-regexp (prj)
  "Return a regular expression equivalent to `project-ignore-files-globs'."
  (let ((globs (project-ignore-files-globs prj)))
    (cond
     ((= 1 (length globs))
      (dired-glob-regexp (car globs)))

     (t
      (concat "\\(" (mapconcat #'dired-glob-regexp globs "\\)\\|\\(") "\\)"))
     )))

(cl-defgeneric project-find-file (prj filename)
  "Find FILENAME with completion in current project PRJ."
  (let* ((flat-path (project-flat-search-path prj))
	 (regexp (project-ignore-files-regexp prj))
	 (predicate
	  (lambda (filename)
	    (not (string-match regexp filename)))))

    (setq filename
	  (completing-read
	   "file: " ;; prompt
	   (completion-table-dynamic (apply-partially 'find-file-path-completion-table flat-path predicate))
	   nil
	   t ;; require match
	   filename
	   ))

    ;; If text properties were preserved by completing-read, we could
    ;; store the full directory in a text property on the
    ;; conflicts. But they are not, so we construct a relative path to
    ;; ensure the filename is found on `flat-path'.
    (when (string-match find-file-uniquify-regexp filename)
	(let ((dir (match-string 2 filename))
	      (prefix "../")
	      (i 0))

	  (while (< i (length dir))
	    (when (= (aref dir i) ?/)
	      (setq prefix (concat prefix "../")))
	    (setq i (1+ i)))

	  (setq filename
		(concat prefix
			dir
			"/"
			(match-string 1 filename)))
	  ))

    (let ((absfilename (locate-file filename flat-path nil)))
      (if absfilename
	  (find-file absfilename)
	;; FIXME: need human-readable name for project
	(error "'%s' not found in project." filename)))
    ))

(defun find-file-project (filename)
  "Find FILENAME (default prompt) with completion in current project.
With prefix arg, FILENAME defaults to filename at point."
  (interactive (list (when current-prefix-arg (thing-at-point 'filename))))
  (project-find-file (project-current) filename))


(defgroup project-vc nil
  "Project implementation using the VC package."
  :group 'tools)

(defcustom project-vc-search-path nil
  "List ot directories to include in `project-search-path'.
The file names can be absolute, or relative to the project root."
  :type '(repeat file)
  :safe 'listp)

(defcustom project-vc-ignores nil
  "List ot patterns to include in `project-ignores'."
  :type '(repeat string)
  :safe 'listp)

(defun project-try-vc (dir)
  (let* ((backend (ignore-errors (vc-responsible-backend dir)))
         (root (and backend (ignore-errors
                              (vc-call-backend backend 'root dir)))))
    (and root (cons 'vc root))))

(cl-defmethod project-roots ((project (head vc)))
  (list (cdr project)))

(cl-defmethod project-search-path ((project (head vc)))
  (append
   (let ((root (cdr project)))
     (mapcar
      (lambda (dir) (expand-file-name dir root))
      (project--value-in-dir 'project-vc-search-path root)))
   (cl-call-next-method)))

(cl-defmethod project-ignores ((project (head vc)) dir)
  (let* ((root (cdr project))
          backend)
    (append
     (when (file-equal-p dir root)
       (setq backend (vc-responsible-backend root))
       (mapcar
        (lambda (entry)
          (if (string-match "\\`/" entry)
              (replace-match "./" t t entry)
            entry))
        (vc-call-backend backend 'ignore-completion-table root)))
     (project--value-in-dir 'project-vc-ignores root)
     (cl-call-next-method))))

(defun project-ask-user (dir)
  (cons 'user (read-directory-name "Project root: " dir nil t)))

(cl-defmethod project-roots ((project (head user)))
  (list (cdr project)))

(defun project-prune-directories (dirs)
  "Returns a copy of DIRS sorted, without subdirectories or non-existing ones."
  (let* ((dirs (sort
                (mapcar
                 (lambda (dir)
                   (file-name-as-directory (expand-file-name dir)))
                 dirs)
                #'string<))
         (ref dirs))
    ;; Delete subdirectories from the list.
    (while (cdr ref)
      (if (string-prefix-p (car ref) (cadr ref))
          (setcdr ref (cddr ref))
        (setq ref (cdr ref))))
    (cl-delete-if-not #'file-exists-p dirs)))

(defun project--value-in-dir (var dir)
  (with-temp-buffer
    (setq default-directory dir)
    (hack-dir-local-variables-non-file-buffer)
    (symbol-value var)))

(provide 'project)
;;; project.el ends here