Switch branches/tags
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
635 lines (552 sloc) 23.8 KB
;;; projectur.el --- Support for projects in Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2012-2013 Victor Deryagin
;; Author: Victor Deryagin <>
;; Created: 3 Aug 2012
;; Version: 0.2.1
;; This file is not part of GNU Emacs.
;; 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, 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
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(require 'cl-lib)
(require 'ido)
(declare-function recompile "compile")
(defgroup projectur nil
"Tool for managing and navigating projects."
:prefix "projectur-"
:group 'tools
:group 'convenience)
(defcustom projectur-tags-default-command "exuberant-ctags -e --recurse ."
"Shell command for generating TAGS file for project.
Executed in context of projects root directory."
:group 'projectur
:type 'string)
(defcustom projectur-ignored-dirs
'(".hg" ".git" ".bzr" ".svn" ".rbx" "_darcs" "_MTN" "CVS" "RCS" "SCCS" "tmp" "node_modules"
".idea" ".cabal-sandbox" "vendor" "dist" "bower_components" ".module-cache")
"List of names of directories, content of which will be excluded from any project."
:group 'projectur
:type '(choice (repeat :tag "Ignored directories" string)
(const :tag "No ignored directories" nil)))
(defcustom projectur-ignored-files
'("*.elc" "*.rbc" "*.py[co]" "*.a" "*.o" "*.so" "*.bin" "*.class"
"*.s[ac]ssc" "*.sqlite3" "TAGS" ".gitkeep" "*~" "#*#" "*.hi"
"List of wildcards, matching names of files, which will be excluded from any project."
:group 'projectur
:type '(choice (repeat :tag "Ignored files" string)
(const :tag "No ignored files" nil)))
(defcustom projectur-default-readme-file-name ""
"Default name for project README file."
:group 'projectur
:type 'string)
(defcustom projectur-project-types
'((:type "Version-controlled ruby project"
:test projectur-ruby-project-under-version-control-p
:tags-command "exuberant-ctags -e **/*.rb"
:ignored-dirs ("tmp" "pkg"))
(:type "sbt project"
:test projectur-sbt-project-p
:ignored-dirs ("project" "target"))
(:type "cabal project"
:test projectur-cabal-project-p
:ignored-dirs ("dist"))
(:type "Leiningen project"
:test projectur-lein-project-p
:ignored-dirs ("target"))
(:type "Cargo project"
:test projectur-cargo-project-p
:ignored-dirs ("target")
:compile-command "cargo build")
(:type "Generic version-controlled project"
:test projectur-version-controlled-repo-p))
"A list with projects types descriptions."
:group 'projectur
:type '(repeat (plist :tag "Project type specification")))
(defvar projectur-history nil "List of visited projects.")
(defvar projectur-command-prefix (kbd "C-c p")
"Prefix of projectur bindings.")
(defvar projectur-map
(let ((map (make-sparse-keymap)))
(define-key map "!" 'projectur-execute-shell-command)
(define-key map "+" 'projectur-set-project-root)
(define-key map "." 'projectur-show-current-file)
(define-key map "R" 'projectur-goto-readme)
(define-key map "T" 'projectur-generate-tags)
(define-key map "a" 'projectur-ack)
(define-key map "d" 'projectur-delete-from-history)
(define-key map "f" 'projectur-find-file)
(define-key map "g" 'projectur-rgrep)
(define-key map "r" 'projectur-goto-root)
(define-key map "c" 'projectur-recompile)
(define-key map (kbd "C-x C-s") 'projectur-save)
(define-key map (kbd "C-x k") 'projectur-kill-buffers)
"Key map with projectur commands.")
(define-key global-map projectur-command-prefix projectur-map))
(defmacro projectur-with-project (project &rest body)
"With `default-directory' bound to PROJECT root directory execute BODY."
(declare (indent 1))
(unless (projectur-project-valid-p ,project)
(error "Invalid project: %s" ,project))
(let ((default-directory (projectur-project-root ,project))
(compile-command (projectur--compile-command ,project)))
(defmacro projectur-with-current-project (&rest body)
"With `default-directory' bound to root directory of current project execute BODY."
(declare (indent 0))
`(let ((project (projectur-current-project)))
(unless (projectur-project-valid-p project)
(error "Current buffer does not seem to belong to any project"))
(projectur-with-project project
(defun projectur--compile-command (project)
"Return value of `compile-command' appropriate for current PROJECT."
(plist-get (cdr project) :compile-command)
(defun projectur-history-cleanup ()
"Delete invalid and duplicate projects from `projectur-history'."
(setq projectur-history
(cl-loop for project in projectur-history
for root = (projectur-project-root project)
if (and
(projectur-project-valid-p project)
(not (member root seen-roots)))
collect project into projects and collect root into seen-roots
finally return projects)))
(defun projectur-history-add (project)
"Add PROJECT to `projectur-history'."
(when project
(let ((root (projectur-project-root project))
(conflicting-root (projectur-conflicting-root-from-history project)))
(when conflicting-root
(error "Failed to add project in '%s': conflict with other one in '%s'"
(abbreviate-file-name root)
(abbreviate-file-name conflicting-root)))
(add-to-list 'projectur-history project)
(defun projectur-conflicting-root-from-history (project)
"Return root of project from `projectur-history' PROJECT conflicts with.
Return nil if no conflicts detected. Conflict is understood as
parent-directory/subdirectory relationships between root of PROJECT
and root of some other project from history.
Special case is when root of PROJECT matches root of project from
history, this is not considered a conflict, duplication is dealt
with by `projectur-history-cleanup'."
(cl-loop with root = (projectur-project-root project)
for other-root in (mapcar 'projectur-project-root projectur-history)
if (or (projectur-subdirectory-p root other-root)
(projectur-subdirectory-p other-root root))
return other-root))
(defun projectur-project-valid-p (project)
"Return non-nil if PROJECT is valid, nil otherwise."
(let ((root (car project))
(test (plist-get (cdr project) :test)))
(stringp root)
(file-directory-p root)
(if test
(funcall test root)
(defun projectur-current-project ()
"Return project current buffer belongs to, nil if none."
(let ((project (or
(projectur-history-add project)
(defun projectur-project-try-find-in-history ()
"Make attempt to find current buffer's project in `projectur-history'.
Return nil if unsuccessful."
(cl-loop with current-directory = (expand-file-name (file-name-as-directory default-directory))
for project in projectur-history
for root = (projectur-project-root project)
if (or (string= current-directory root)
(projectur-subdirectory-p current-directory root))
return project))
(defun projectur-subdirectory-p (subdir dir)
"Return non-nil if SUBDIR is a subdirectory of DIR, nil otherwise."
(let ((subdir (file-name-as-directory subdir))
(dir (file-name-as-directory dir)))
(and (> (length subdir) (length dir))
(string-prefix-p dir subdir))))
(defun projectur-project-try-fetch ()
"Attempt to fetch current project, return nil if unsuccessful."
(let ((dir (expand-file-name default-directory)))
(unless (file-remote-p dir)
(projectur-project-containing-dir dir))))
(defun projectur-project-containing-dir (dir)
"Return project DIR belongs to, return nil if none."
(cl-loop for project-type in projectur-project-types
for test-function = (plist-get project-type :test)
for root = (locate-dominating-file dir test-function)
if root
return (cons (file-name-as-directory root)
(cl-defun projectur-select-project-from-history (&optional (prompt "Select project: "))
"Select single project from `projectur-history'."
prompt projectur-history
(lambda (project)
(let* ((root (abbreviate-file-name
(projectur-project-root project)))
(name (projectur-project-name project)))
(format "%-30s (%s)" name root)))))
(defun projectur--find-projects-in-dir (dir)
"Find all projects within DIR."
(let ((project (projectur-project-containing-dir dir)))
(if project
(list project)
(cl-loop for subdir in (directory-files dir 'full-path (rx string-start (not (any "."))))
unless (or (member (file-name-base subdir) projectur-ignored-dirs)
(not (file-directory-p subdir)))
append (projectur--find-projects-in-dir subdir) into projects
finally return projects))))
(defun projectur-discover-projects (dir)
"Go through DIR recursively and add all found projects to `projectur-history'.
When called interactively report total number of projects
discovered and how many of them are new (not already present in
(interactive "DDirectory to find projects in: ")
(let ((projects (projectur--find-projects-in-dir dir))
(setq history-size-before (length projectur-history))
(lambda (project)
(add-to-list 'projectur-history project))
(when (called-interactively-p)
(message "Found %d projects (%d new)"
(length projects)
(- (length projectur-history) history-size-before)))))
(defun projectur-project-root (project)
"Return root directory of PROJECT."
(car project))
(defun projectur-project-tags-command (project)
"Return TAGS generation comman for PROJECT."
(plist-get (cdr project) :tags-command)
(defun projectur-project-name (project)
"Return name of PROJECT."
(projectur-project-root project))))
(defun projectur-project-ignored-dirs (project)
"Return list of ignored directories for PROJECT."
(append projectur-ignored-dirs
(plist-get (cdr project) :ignored-dirs)))
(defun projectur-project-ignored-files (project)
"Return list of wildcards of ignored files for PROJECT."
(append projectur-ignored-files
(plist-get (cdr project) :ignored-files)))
(defun projectur-project-readme (project)
"Find README file for project PROJECT, return nil if none."
(cl-loop with root = (projectur-project-root project)
for pattern in (mapcar
(lambda (p) (expand-file-name p root))
'("Readme*" "readme*" "README*"))
thereis (car (file-expand-wildcards pattern))))
(defun projectur-find-cmd (project)
"Generate find(1) command for finding al relevant files withing PROJECT."
(let ((ignored-dirs (projectur-project-ignored-dirs project))
(ignored-files (projectur-project-ignored-files project)))
(projectur-with-project project
`(prune (name ,@ignored-dirs))
`(not (iname ,@ignored-files))
'(type "f")
(defun projectur-project-files (project)
"List of absolute names for files, belonging to PROJECT."
(let ((command (projectur-find-cmd project)))
(delete ""
(shell-command-to-string command)
(defun projectur-buffers (project)
"Return list of buffers, visiting files, belonging to PROJECT."
(cl-loop for buf in (buffer-list)
if (projectur-buffer-in-project-p buf project)
collect buf))
(defun projectur-buffer-in-project-p (buffer-or-name project)
"Return non-nil if BUFFER-OR-NAME belongs to PROJECT."
(let ((buf (get-buffer buffer-or-name))
(root (expand-file-name (projectur-project-root project)))
(with-current-buffer buf
(setq location (or buffer-file-name default-directory)))
(and location
(string-prefix-p root (expand-file-name location)))))
(defun projectur-goto-root (choose-project)
"Open root directory of current project.
If CHOOSE-PROJECT is non-nil or current buffer does not belong
to any project, ask to choose project from list and use it as
context for executing."
(interactive "P")
(let (project)
(unless choose-project
(setq project (projectur-current-project)))
(unless project
(setq project (projectur-select-project-from-history)))
(find-file (projectur-project-root project))))
(defun projectur-find-file (choose-project)
"Open file from current project.
If CHOOSE-PROJECT is non-nil or current buffer does not belong
to any project, ask to choose project from list and use it as
context for executing."
(interactive "P")
(let (project)
(unless choose-project
(setq project (projectur-current-project)))
(unless project
(setq project (projectur-select-project-from-history)))
(projectur-with-project project
(let ((files (projectur-project-files project))
(root (projectur-project-root project)))
(if (= 1 (length files))
(car files)
"Find file in project: " files
(lambda (file) (file-relative-name file root)))))))))
(defun projectur-set-project-root (dir)
"Set DIR as root of current project."
(interactive "DProject root: ")
(list (file-name-as-directory (expand-file-name dir)))))
(defun projectur-delete-from-history ()
"Select project to delete from `projectur-history'."
(let ((project (projectur-select-project-from-history "Delete project: ")))
(setq projectur-history
(delete project projectur-history))
(message "Project \"%s\" deleted from history."
(abbreviate-file-name (projectur-project-root project)))))
(defun projectur-kill-buffers (&optional limit-to-mode)
"Kill all buffers (even unsaved) visiting files from current project.
If LIMIT-TO-MODE is true, ask for major mode and kill only those buffers with chosen major mode."
(interactive "P")
(let* ((project (projectur-current-project))
(project-name (projectur-project-name project))
(buffers (projectur-buffers project))
(modes (delete-dups (mapcar (lambda (buf) (with-current-buffer buf major-mode)) buffers)))
(if buffers
(when (or limit-to-mode
(format "About to kill buffers for all opened files from project '%s'. Are you sure? "
(when (and limit-to-mode
(> (length modes) 1))
(setq mode (intern (ido-completing-read "Kill buffers in mode: " (mapcar 'symbol-name modes)))))
(lambda (buf)
(when (or (not mode)
(with-current-buffer buf (derived-mode-p mode)))
(kill-buffer buf)))
(message "Nothing to do, there are currently no opened files from project '%s'."
(defun projectur-rgrep ()
"Run `rgrep' command in context of the current project root directory."
(call-interactively 'rgrep)))
(defun projectur-execute-shell-command ()
"Execute shell command in context of the current project root directory."
(call-interactively 'shell-command)))
(defun projectur-ack ()
"Run `ack' command (if available) in context of the current project root directory."
(if (fboundp 'ack)
(call-interactively 'ack)
(error "You need `ack' command installed in order to use this functionality"))))
(defun projectur-generate-tags ()
"Generate TAGS file for current project."
(let ((command (projectur-project-tags-command project)))
(read-string "Generate TAGS like this: "
command nil command))
(setq tags-file-name (expand-file-name "TAGS")))))
(defun projectur-save ()
"Save all opened files that belong to current project."
(lambda (buf)
(with-current-buffer buf
(when buffer-file-name
(projectur-buffers (projectur-current-project))))
(defun projectur-revert ()
"Revert all buffers visiting files from current project."
(lambda (buf)
(with-current-buffer buf
(revert-buffer nil 'noconfirm 'preserve-modes)))
(projectur-buffers (projectur-current-project))))
(defun projectur-goto-readme ()
"Go to README file in current project root directory, create one if it does not exist."
(let* ((project (projectur-current-project))
(root (projectur-project-root project))
(readme (or (projectur-project-readme project)
(expand-file-name projectur-default-readme-file-name root))))
(find-file readme)))
(cl-defun projectur-complete (prompt choices &optional (display-fn 'identity))
"Select one of CHOICES, with PROMPT, use DISPLAY-FN for display if provided,
`identity' otherwise."
(let* ((ido-decorations '("\n-> " "" "\n " "\n ..." "[" "]"
" [No match]" " [Matched]" " [Not readable]"
" [Too big]" " [Confirm]"))
(ido-enable-flex-matching t)
(mapcar (lambda (choice)
(cons (funcall display-fn choice) choice))
(mapcar 'car results-map))
(ido-completing-read prompt display-choices)))
(cdr (assoc chosen results-map))))
(defun projectur-show-current-file ()
"Show path of current file relative to its project root in minibuffer.
Show absolute path if current file does not belong to any project.
Display error if current buffer is not visiting a file."
(unless buffer-file-name
(error "Current buffer does not belong to any project"))
(let ((project (projectur-current-project)))
(if project
(file-relative-name buffer-file-name
(projectur-project-root project))
(abbreviate-file-name buffer-file-name)))))
(defun projectur-recompile (&optional edit-command)
"Execute `recompile' in context of root of current project.
Input compilation command if EDIT-COMMAND is not nil."
(interactive "P")
(recompile edit-command)))
(defun projectur-git-repo-p (dir)
"Return non-nil if DIR is a root of git repository, nil otherwise."
(file-directory-p (expand-file-name ".git" dir)))
(defun projectur-mercurial-repo-p (dir)
"Return non-nil if DIR is a root of mercurial repository, nil otherwise."
(file-directory-p (expand-file-name ".hg" dir)))
(defalias 'projectur-hg-repo-p 'projectur-mercurial-repo-p)
(defun projectur-subversion-repo-p (dir)
"Return non-nil if DIR is a root of subversion repository, nil otherwise."
(file-directory-p (expand-file-name ".svn" dir))
(not (file-directory-p (expand-file-name "../.svn" dir)))))
(defalias 'projectur-svn-repo-p 'projectur-subversion-repo-p)
(defun projectur-bazaar-repo-p (dir)
"Return non-nil if DIR is a root of bazaar repository, nil otherwise."
(file-directory-p (expand-file-name ".bzr" dir)))
(defalias 'projectur-bzr-repo-p 'projectur-bazaar-repo-p)
(defun projectur-cvs-repo-p (dir)
"Return non-nil if DIR is a root of CVS repository, nil otherwise."
(file-directory-p (expand-file-name "CVS" dir))
(not (file-directory-p (expand-file-name "../CVS" dir)))))
(defun projectur-darcs-repo-p (dir)
"Return non-nil if DIR is a root of Darcs repository, nil otherwise."
(file-directory-p (expand-file-name "_darcs" dir)))
(defun projectur-ruby-gem-p (dir)
"Return non-nil if DIR is a root of ruby gem source tree, nil otherwise."
(file-expand-wildcards (expand-file-name "*.gemspec" dir)))
(defun projectur-rails-app-p (dir)
"Return non-nil if DIR is a root of ruby-on-rails application, nil otherwise."
(file-regular-p (expand-file-name "script/rails" dir)))
(defun projectur-rake-project-p (dir)
"Return non-nil if DIR is a root of project using rake, nil otherwise."
(cl-loop for rakefile in '("rakefile" "Rakefile" "rakefile.rb" "Rakefile.rb")
thereis (file-regular-p (expand-file-name rakefile dir))))
(defun projectur-bundler-project-p (dir)
"Return non-nil if DIR is a root of project using bundler, nil otherwise."
(file-regular-p (expand-file-name "Gemfile" dir)))
(defun projectur-version-controlled-repo-p (dir)
"Return non-nil if DIR is a root of version-controlled project, nil otherwise.
Supported VCS: git, mercurial, subversion, bazaar, cvs, darcs."
(projectur-git-repo-p dir)
(projectur-mercurial-repo-p dir)
(projectur-subversion-repo-p dir)
(projectur-bazaar-repo-p dir)
(projectur-cvs-repo-p dir)
(projectur-darcs-repo-p dir)))
(defun projectur-ruby-project-under-version-control-p (dir)
"Return non-nil if DIR is a root of version-controlled ruby project."
(projectur-version-controlled-repo-p dir)
(projectur-rails-app-p dir)
(projectur-ruby-gem-p dir)
(projectur-bundler-project-p dir)
(file-regular-p (expand-file-name "spec/spec_helper.rb" dir))
(file-regular-p (expand-file-name "test/test_helper.rb" dir))
(file-regular-p (expand-file-name "features/support/env.rb" dir))
(file-regular-p (expand-file-name ".rspec" dir))
(file-regular-p (expand-file-name ".rvmrc" dir))
(file-regular-p (expand-file-name ".ruby-version" dir))
(file-regular-p (expand-file-name ".rbenv-version" dir)))))
(defun projectur-sbt-project-p (dir)
"Return non-nil if DIR is a root of sbt project, nil otherwise."
(file-regular-p (expand-file-name "build.sbt" dir)))
(defun projectur-cabal-project-p (dir)
"Return non-nil if DIR is a root of cabal project, nil otherwise."
(file-regular-p (expand-file-name "Setup.hs" dir))
(file-regular-p (expand-file-name "Setup.lhs" dir)))
(file-expand-wildcards (expand-file-name "*.cabal" dir))))
(defun projectur-lein-project-p (dir)
"Return non-nil if DIR is a root of Leiningen project, nil otherwise."
(file-regular-p (expand-file-name "project.clj" dir)))
(defun projectur-cargo-project-p (dir)
"Return non-nil if DIR is a root of Cargo project, nil otherwise."
(file-regular-p (expand-file-name "Cargo.toml" dir)))
(provide 'projectur)
;;; projectur.el ends here