;;; project.el russell young 2006
;;; 
;;; This lets you group files into projects to load at a single
;;; command. It is a little rough, particularly on handling existing
;;; projects, but it works pretty well.
;;;
;;; TO LOAD: just load this file in your .emacs file. Be sure to set
;;; the project file name in proj-file to a location on your system.
;;;
;;; TO USE: Visit all the files for your project in your emacs
;;; session. When everything is in use the command "M-x
;;; proj-make". This will put up an interactive buffer where you can
;;; give a project name and select the files to be included in
;;; it. Next time you start up emacs and want to reload the selected
;;; files use the command "M-x proj-load" to reload all those files.
;;; "M-x proj-list" will put up a menu of files in the current
;;; project, showing whether they are changed and allowing you to jump
;;; to any of them. Finally, "M-x proj-unload" will kill all buffers
;;; for the project. With optional arg INSTRUCTIONS > 0 any modified
;;; files will be saved, with < 0 they will be discarded, if not given
;;; the user will be prompted.
;;; 

(load "cl-extra")

(defvar *proj-current* nil 
  "Current project opened/displayed by the PROJ package")

(defvar proj-make-buffer "*Make project*"
  "Project buffer name")

(defvar *all-projects* nil
  "Variable to hold all projects")

(defgroup proj nil
  "Save sets of files as projects.
Interactive function to let you load groups of files with a single
command. Use the function 'M-x proj-make' to call up an interactive
menu to create a project by selecting buffers currently being 
visited. The function 'M-x proj-load' lets you select a stored 
project to load."
  :group 'tools
  :prefix "proj-")

(defcustom proj-file "~/projects.dat"
  "Location for project data file"
  :group 'proj
  :type 'string)

(defcustom proj-confirm-delete t
  "Require confirmation on delete-project command"
  :group 'proj
  :type 'boolean)

(defcustom proj-popup-width 30
  "Width of popup list buffer"
  :group 'proj
  :type 'integer)

(defcustom proj-on-face 'bold
  "Face used for projects selected on the Project Selection form"
  :type 'face
  :group 'proj)

(defcustom proj-name-face 'red
  "Face used for the project name on the Project Selection form"
  :type 'face
  :group 'proj)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; proj-make
;;
;; Makes or edits a project. This puts up a screen with all currently
;; visited buffers and allows the user to select which ones to include
;; in the project being defined.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun proj-make (&optional name)
  "Creates a project consisting of files that are all loaded with a single command.
Use the command 'M-x proj-load' to load all the files in the project"
  (interactive)
  (or *all-projects* (proj-read-all)) ; (error "Cannot find project load file"))
  (proj-make-buffer (or (and (eq name t) *proj-current*) name (proj-choose nil))))

(defun proj-make-buffer (name)
  "Makes the interactive buffer for creating or editing a project.
All open buffers with associated files are offered as selections for
the project. If the project exists all files currently in the project 
are offered, with ones currently being visited automatically selected.
The order the files are loaded is from bottom to top, so the topmost
file will be the one on top when the load completes.
"
  (if (symbolp name) 
	  (setq project name
			name (symbol-name name))
	(setq project (intern name)))

  (let* ((existing (proj-make-existing (assoc project *all-projects*)))
		 (files (loop for b in (buffer-list)
						do (set-buffer b) 
						if (and buffer-file-name (not (assoc buffer-file-name existing)))
						collect (list buffer-file-name)))
		 (buffer (get-buffer-create proj-make-buffer)))
	(switch-to-buffer buffer)
	(make-local-variable 'project)
	(erase-buffer)
	(insert "Project " (proj-highlight-name name) "\n\nFiles:\n")
	(when existing 
	  (insert "------- Existing project files -------\n")
	  (mapc 'proj-make-entry existing)
	  (insert "------- End of existing files -------\n"))
	(mapc 'proj-make-entry files)
	(insert "\n\n<SPACE> or x to toggle selection
s or ^C-x ^C-s to save
d to delete project
q to quit
r to rename
^C-k to delete a file from the buffer
^C-up to move the file on the current line up
^C-down to move the file on the current line down
")
	(or proj-make-local-keymap
		(setq proj-make-local-keymap (proj-make-keymap proj-make-keys)))
	(use-local-map proj-make-local-keymap)
	(goto-char 1)
	(proj-next)
	))

(defun proj-make-existing (proj)
  "Read in the files currently in the project. 
This maintains the order of the files and that none are lost when edited"
  (reverse (mapcar (lambda (x) (list x (find-buffer-visiting x))) (cdr proj))))

(defun proj-make-entry (file) 
  "Internal function to make a single entry in the project file list"
  (let ((name (copy-seq (car file)))
		(chosen "_"))
	(put-text-property 0 (length name) 'face nil name)
	(put-text-property 0 1 'proj-file file chosen)
	(insert (concat "\t" chosen " " name "\n"))
	(when (second file)
	  (backward-char 1)
	  (proj-make-toggle)
	  (end-of-buffer))))

(defun proj-save (proj files)
  "Writes the project definition file"
  (let ((buffer (find-file-noselect proj-file))
		(existing (assoc proj *all-projects*))
		(new (cons project files))
		)
	(setq *all-projects* (cons new (remove existing *all-projects*)))
	(set-buffer buffer)
	(erase-buffer)
	(set-syntax-table emacs-lisp-mode-syntax-table)
	(cl-prettyprint *all-projects*)
	(save-buffer)
	(kill-buffer buffer))
  (kill-buffer proj-make-buffer)
  )

(defvar proj-make-keys 
  '(("\t" proj-next)
	([down] proj-next)
	([up] proj-prev)
	([right] proj-next)
	([left] proj-prev)
	(" " proj-make-toggle)
	("x" proj-make-toggle)
	("q" proj-make-quit)
	("s" proj-make-save)
	("\C-x\C-s" proj-make-save)
	("r" proj-make-rename)
	("d" proj-make-delete)
	("\C-k" proj-make-delete-line)
	([C-up] proj-make-line-up)
	([C-down] proj-make-line-down))
  "The commands for the PROJ-MAKE buffer")

(defun proj-load (&optional project)
  "Load all files in a given project.
Projects are defined interactively with the proj-make command."
  (interactive)
  (or *all-projects* (proj-read-all))
  (if (eq project t) (setq project *proj-current*)
	(or project (setq project (proj-choose t))))
  (let ((desc (assoc project *all-projects*)))
	(or desc (error "Cannot find project description for %s" project))
	(mapc 'find-file (cdr desc))
	(proj-list project)
	(setq *proj-current* project)
	(message "Project %s loaded, %s files" project (1- (length desc)))
	))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; proj-list
;;
;; Puts up a list of the files in the project. This lets the caller
;; see the file status and jump to each file in the project.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun proj-list (&optional project point)
  (interactive)
  (or *all-projects* (proj-read-all))
  (if (eq project t) (setq project *proj-current*)
	(or project (setq project (proj-choose t))))
  (let* ((buffer (get-buffer-create (format "*project %s*" project)))
		 (desc (or (cdr (assoc project *all-projects*)) 
				   (error "Cound not find descriptor for project '%s'" project))))
	(switch-to-buffer buffer)
	(erase-buffer)
	(use-local-map (or proj-list-local-keymap 
					   (setq proj-list-local-keymap (proj-make-keymap proj-list-keys))))
	(setq truncate-lines t)
	(insert "Project buffer for project " (proj-highlight-name project)
			"\n\n\t  Buffer                    Directory
----------------------------------------------------------------------\n")
	(mapc 'proj-list-line desc)
	(end-of-buffer)
	(insert "\n\n
Key: * : file modified
     - : file not modified
     X : file not being visited")
	(setq *proj-current* project)
	(if point (goto-char point)
	  (goto-char 0)
	  (proj-next))))

(defun proj-list-line (file)
  (let* ((buffer (find-buffer-visiting file))
		 (name (if buffer (buffer-name buffer) (file-name-nondirectory file)))
		 (modified (if buffer (if (buffer-modified-p buffer) "*" "-") "X"))
		 (string (format "%s %s %s" modified
						 (proj-pad name 25)
						 (file-name-directory file))))
	(put-text-property 0 (length string) 'proj-file file string)
	(insert "\t" string "\n"))
  (beginning-of-line 0)
)

(defvar proj-list-keys 
  '(("\t" proj-next)
	([down] proj-next)
	([up] proj-prev)
	([right] proj-next)
	([left] proj-prev)
	("q" proj-list-quit)
	("\C-m" proj-list-view)
	("l" (lambda () (interactive) (proj-load t)))
	("e" (lambda () (interactive) (proj-make t)))
	)
  "The commands for the PROJ-LIST buffer")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Unloads a project
;;
;; Closes all buffers visiting project files
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun proj-unload (&optional project instructions)
  "Closes all buffers for files for the given project
Optional argument INSTRUCTIONS if present and > 0 means save all modified
buffers, if < 0 means discard all changes, if nil then ask for each."
  (interactive)
  (or *all-projects* (proj-read-all))
  (if (eq project t) (setq project *proj-current*)
	(or project (setq project (proj-choose t))))
  (let* ((desc (or (cdr (assoc project *all-projects*)) 
				   (error "Cound not find descriptor for project '%s'" project))))
	(mapcar 'proj-unload-one desc))
  (and (equal *all-projects* project) (setq *all-projects* nil))
  (message "Project %s: all buffers closed" project))

(defun proj-unload-one (file)
  (let* ((buffer (find-buffer-visiting file)))
	(when buffer
	  (if (buffer-modified-p buffer)
		  (if (or (and (not instructions) (y-or-n-p (concat "Save " file "? ")))
				  (and instructions (> instructions 0)))
			  (with-current-buffer buffer (save-buffer))
			(with-current-buffer buffer (set-buffer-modified-p nil))))
	  (kill-buffer buffer))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Keymaps and functions
;;
;; Builds the keymaps and defines the functions mapped to the keys
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar proj-list-local-keymap nil "keymap for the PROJ-LIST buffer")
(defvar proj-make-local-keymap nil "keymap for the PROJ-MAKE buffer")

(defun proj-make-keymap (desc)
  "Makes a keymap from a descriptor.
Descriptor is alist of (key function)"
  (let ((map (make-sparse-keymap)))
	(suppress-keymap map t)
	(mapc (lambda (x) (apply 'define-key map x)) desc)
	map))

;; Common functions
(defun proj-next (&optional top)
  "Goes to the next file in the selection menu"
  (interactive)
  (if (re-search-forward "^\t[*-X] " nil t) (backward-char 2)
	(and top (error "No files in this buffer"))
	(goto-char 0)
	(proj-next t)))

(defun proj-prev (&optional bottom)
  "Goes to the previous file in the selection menu"
  (interactive)
  (if (re-search-backward "^\t[*-X] " nil t) (forward-char 1)
	(and bottom (error "No files in this buffer"))
	(end-of-buffer)
	(proj-prev t)))
	
;; Functions for PROJ-MAKE
(defun proj-make-toggle ()
  "Toggles the selection of a file in the project definition buffer"
  (interactive)
  (beginning-of-line)
  (let* ((end (line-end-position))
		 (pos (or (re-search-forward "^[ \t]*\\([X_]\\)" end t)
				  (error "No file on this line")))
		 (on (equal (buffer-substring-no-properties (1- pos) pos) "_"))
		 (new-char (if on "X" "_"))
		 (proj-file (get-text-property (1- pos) 'proj-file))
		 )
	(goto-char (1- pos))
	(delete-char 1)
	(put-text-property 0 1 'proj-file proj-file new-char)
	(put-text-property (point) (line-end-position) 'face (if on proj-on-face))
	(insert new-char)
	))

(defun proj-make-save ()
  "Saves a project."
  (interactive)
  (or project (error "No name for this project"))
  (goto-char 0)
  (let ((files ()))
	(while (re-search-forward "^[ \t]*X *\\(.*\\)$" nil t)
	  (setq files (cons (match-string-no-properties 1) files))
	  )
	(proj-save project files)))

(defun proj-make-rename (proj) 
  "Renames the current project definition"
  (interactive "SName: ")
  (setq project proj)
  (let* ((start (next-single-property-change 1 'face))
		 (end (next-single-property-change start 'face))
		 (name (symbol-name proj)))
	(goto-char start)
	(delete-char (- end start))
	(insert (proj-highlight-name name))
	(proj-next)))

(defun proj-make-delete () 
  "Deletes the current project definition"
  (interactive)
  (let ((current (current-buffer))
		(buffer (find-file-noselect proj-file))
		(existing (assoc project *all-projects*))
		(proj project)
		)
	(or existing (error "Cannot find entry for %s" project))
	(if (and proj-confirm-delete
			 (not (y-or-n-p (format "Really delete project %s?" project))))
		(message "Cancelled")
	  (setq *all-projects* (remove existing *all-projects*))
	  (set-buffer buffer)
	  (erase-buffer)
	  (set-syntax-table emacs-lisp-mode-syntax-table)
	  (cl-prettyprint *all-projects*)
	  (save-buffer)
	  (message "Deleted project %s" proj)
	  (kill-buffer buffer)
	  (kill-buffer current))))

(defun proj-make-delete-line ()
  (interactive)
  (delete-region (line-beginning-position) (line-beginning-position 2))
  (forward-char)
  )

(defun proj-make-line-up ()
  (interactive)
  (if (previous-single-property-change (line-beginning-position) 'proj-file)
	  (let* ((start (line-beginning-position))
			 (next (line-beginning-position 2))
			 (line (buffer-substring start next)))
		(delete-region start next)
		(beginning-of-line 0)
		(insert line)
		(proj-prev))))

(defun proj-make-line-down ()
  (interactive)
  (if (next-single-property-change (line-end-position) 'proj-file)
	  (let* ((start (line-beginning-position))
			 (next (line-beginning-position 2))
			 (line (buffer-substring start next)))
		(delete-region start next)
		(beginning-of-line 2)
		(insert line)
		(proj-prev))))

(defun proj-make-quit ()
  "Quits the project definition buffer"
  (interactive)
  (kill-buffer proj-make-buffer)
  (message "Exiting project creation"))

;; Functions for PROJ-LIST
(defun proj-list-quit ()
  "Quits the project definition buffer"
  (interactive)
  (kill-buffer (current-buffer)))

(defun proj-list-view () 
  (interactive)
  (let* ((file (or (get-text-property (point) 'proj-file) (error "No file at point")))
		(buffer (find-buffer-visiting file))
		(point (point)))
	(when (not buffer)
	  (setq buffer (find-file file))
	  (proj-list t point))
	(switch-to-buffer buffer)))

(defun proj-list-popup (&optional project)
  "Pops up the list of the current project"
  (interactive)
  (proj-list (or project (and current-prefix-arg (proj-choose t)) *proj-current*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Support functions
;;
;; Miscellaneous other functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun proj-choose (require)
  "Internal function for selecting a project.
REQUIRE is t if an existing project is required, otherwise nil."
  (intern (completing-read "Project: " (mapcar (lambda (x) (list (symbol-name (car x)))) *all-projects*) nil require)))

(defun proj-read-all ()
  "Reads the project definition file and loads all project definitions."
  (let ((buffer (find-file-noselect proj-file))
		result)
	(set-buffer buffer)
	
	(setq *all-projects* (if (> (buffer-size) 0) (car (read-from-string (buffer-string)))))
	(kill-buffer buffer))
  *all-projects*)

(defun proj-highlight-name (name)
  "Highlights the project name in the default face.
Face is customized through variable proj-name-face"
  (let ((string (copy-seq (if (symbolp name) (symbol-name name) name))))
	(put-text-property 0 (length string) 'face proj-name-face string)
	string))

(defun proj-pad (string length)
  "Pads STRING to length LENGTH, if necessary"
  (if (< (length string) length)
	  (concat string (make-string (- length (length string)) ? ))
	string))


(global-set-key "\C-cp" 'proj-list-popup)

(provide 'project)