project-root.el

   1 ;;; project-root.el --- Define a project root and take actions based upon it.
   2
   3 ;; Copyright (C) 2008 Philip Jackson
   4
   5 ;; Author: Philip Jackson <phil@shellarchive.co.uk>
   6 ;; Version: 0.6
   7
   8 ;; This file is not currently part of GNU Emacs.
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program ; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; project-root.el allows the user to create rules that will identify
  28 ;; the root path of a project and then run an action based on the
  29 ;; details of the project.
  30 ;;
  31 ;; Example usage might be might be that you want a certain indentation
  32 ;; level/type for a particular project.
  33 ;;
  34 ;; once project-root-fetch has been run `project-details' will either
  35 ;; be nil if nothing was found or the project name and path in a cons
  36 ;; pair.
  37
  38 ;; An example configuration:
  39
  40 ;; (setq project-roots
  41 ;;       '(("Generic Perl Project"
  42 ;;          :root-contains-files ("t" "lib")
  43 ;;          :on-hit (lambda (p) (message (car p))))))
  44 ;;
  45 ;; I bind the following:
  46 ;;
  47 ;; (global-set-key (kbd "C-c p f") 'project-root-find-file)
  48 ;; (global-set-key (kbd "C-c p g") 'project-root-grep)
  49 ;; (global-set-key (kbd "C-c p a") 'project-root-ack)
  50 ;; (global-set-key (kbd "C-c p d") 'project-root-goto-root)
  51 ;; (global-set-key (kbd "C-c p p") 'project-root-run-default-command)
  52 ;;
  53 ;; (global-set-key (kbd "C-c p M-x")
  54 ;;                 'project-root-execute-extended-command)
  55 ;;
  56 ;; (global-set-key
  57 ;;  (kbd "C-c p v")
  58 ;;  (lambda ()
  59 ;;    (interactive)
  60 ;;    (with-project-root
  61 ;;        (let ((root (cdr project-details)))
  62 ;;          (cond
  63 ;;            ((file-exists-p ".svn")
  64 ;;             (svn-status root))
  65 ;;            ((file-exists-p ".git")
  66 ;;             (git-status root))
  67 ;;            (t
  68 ;;             (vc-directory root nil)))))))
  69 ;;
  70 ;; This defines one project called "Generic Perl Projects" by running
  71 ;; the tests path-matches and root-contains-files. Once these tests
  72 ;; have been satisfied and a project found then (the optional) :on-hit
  73 ;; will be run.
  74
  75 ;;; The tests:
  76
  77 ;; :path-matches maps to `project-root-path-matches' and
  78 ;; :root-contains-files maps to `project-root-upward-find-files'. You
  79 ;; can use any amount of tests.
  80
  81 ;;; Bookmarks:
  82
  83 ;; If you fancy it you can add a :bookmarks property (with a list of
  84 ;; strings) and when you run `project-root-browse-seen-projects' you
  85 ;; will see the bookmarks listed under the project name, linking
  86 ;; relatively to the project root. Also, the bookmarks will present
  87 ;; themselves as anything candidates if you configure as instructed
  88 ;; below.
  89
  90 ;;; The default command
  91
  92 ;; If you give a project a :default-command property you can execute
  93 ;; it by running `project-root-run-default-command'. Nothing fancy but
  94 ;; very handy.
  95
  96 ;;; installation:
  97
  98 ;; Put this file into your `load-path' and evaulate (require
  99 ;; 'project-root).
 100
 101 ;;; Using yourself:
 102
 103 ;; If you wrap a call in `with-project-root' then everything in its
 104 ;; body will execute under project root:
 105 ;;
 106 ;; (with-project-root
 107 ;;  (shell-command-to-string "pwd"))
 108
 109 ;;; anything.el intergration
 110
 111 ;; If you want to add the bookmarks for the current project to the
 112 ;; anything source list then use:
 113 ;;
 114 ;; (add-to-list 'anything-sources
 115 ;;              project-root-anything-config-bookmarks)
 116 ;;
 117 ;; If you want to add the bookmarks for each of the files in the
 118 ;; current project to the anything source list then use:
 119 ;;
 120 ;; (add-to-list 'anything-sources
 121 ;;              project-root-anything-config-files)
 122
 123 (require 'find-cmd)
 124
 125 (eval-when-compile
 126   (defvar anything-project-root)
 127   (require 'outline)
 128   (require 'dired))
 129
 130 (defvar project-root-extra-find-args
 131   (find-to-string '(prune (name ".svn" ".git")))
 132   "Extra find args that will be AND'd to the defaults (which are
 133 in `project-root-file-find-process')")
 134
 135 (defvar project-root-seen-projects nil
 136   "All of the projects that we have met so far in this session.")
 137
 138 (defvar project-root-file-cache nil
 139   "Cache for `completing-read'")
 140
 141 (make-variable-buffer-local
 142  (defvar project-details nil
 143   "The name and path of the current project root."))
 144
 145 (defvar project-root-test-dispatch
 146   '((:root-contains-files . project-root-upward-find-files)
 147     (:path-matches . project-root-path-matches))
 148   "Map a property name to root test function.")
 149
 150 (defvar project-roots nil
 151   "An alist describing the projects and how to find them.")
 152
 153 (defvar project-root-max-search-depth 20
 154   "Don't go any further than this many levels when searching down
 155 a filesystem tree")
 156
 157 (defun project-root-run-default-command ()
 158   "Run the command in :default-command, if there is one."
 159   (interactive)
 160   (with-project-root
 161       (let ((command (project-root-data
 162                       :default-command project-details)))
 163         (when command
 164           (funcall command)))))
 165
 166 (defun project-root-path-matches (re)
 167   "Apply RE to the current buffer name returning the first
 168 match."
 169   (let ((filename (cond
 170                     ((string= major-mode "dired-mode")
 171                      (dired-get-filename nil t))
 172                     (buffer-file-name
 173                      buffer-file-name))))
 174     (when (and filename (not (null (string-match re filename))))
 175       (match-string 1 filename))))
 176
 177 (defun project-root-get-root (project)
 178   "Fetch the root path of the project according to the tests
 179 described in PROJECT."
 180   (let ((root (plist-get project :root))
 181         (new-root))
 182     (catch 'not-a-project
 183       (mapc
 184        (lambda (test)
 185          (when (plist-get project (car test))
 186            ;; grab a potentially different root
 187            (setq new-root
 188                  (funcall (cdr test) (plist-get project (car test))))
 189            (cond
 190              ((null new-root)
 191               (throw 'not-a-project nil))
 192              ;; check root is so far consistent
 193              ((and (not (null root))
 194                    (not (string= root new-root)))
 195               (throw 'not-a-project nil))
 196              (t
 197               (setq root new-root)))))
 198        project-root-test-dispatch)
 199       (when root
 200         (file-name-as-directory root)))))
 201
 202 (defun project-root-data (key &optional project)
 203   "Grab the value (if any) for key in PROJECT. If PROJECT is
 204 ommited then attempt to get the value for the current
 205 project."
 206   (let ((project (or project project-details)))
 207     (plist-get (cdr (assoc (car project) project-roots)) key)))
 208
 209 (defun project-root-bookmarks (&optional project)
 210   "Grab the bookmarks (if any) for PROJECT."
 211   (project-root-data :bookmarks project))
 212
 213 (defun project-root-gen-org-url (project)
 214   ;; The first link to the project root itself
 215   (concat "** [[file:" (cdr project)
 216           "][" (car project)
 217           "]] (" (cdr project)
 218           ")\n"
 219           ;; And now the bookmarks, should there be any
 220           (mapconcat
 221            (lambda (b)
 222              (let ((mark (concat (cdr project) b)))
 223                (concat "*** [[file:" mark "][" b "]] (" mark ")")))
 224            (project-root-bookmarks project)
 225            "\n")
 226           "\n"))
 227
 228 (defun project-root-browse-seen-projects ()
 229   "Browse the projects that have been seen so far this session."
 230   (interactive)
 231   (let ((current-project project-details)
 232         (point-to nil))
 233     (switch-to-buffer (get-buffer-create "*Seen Project List*"))
 234     (erase-buffer)
 235     (insert "* Seen projects\n")
 236     (mapc (lambda (p)
 237             (when (file-exists-p (cdr p))
 238               (when (equal p current-project)
 239                 (setq point-to (point)))
 240               (insert (project-root-gen-org-url p))))
 241           project-root-seen-projects)
 242     (org-mode)
 243     ;; show everything at second level
 244     (goto-char (point-min))
 245     (show-children)
 246     ;; expand bookmarks for current project only
 247     (when point-to
 248       (goto-char (+ point-to 3))
 249       (show-children))
 250     (setq buffer-read-only t)))
 251
 252 ;; TODO: refactor me
 253 (defun project-root-fetch (&optional dont-run-on-hit)
 254   "Attempt to fetch the root project for the current file. Tests
 255 will be used as defined in `project-roots'."
 256   (interactive)
 257   (let ((project
 258          (catch 'root-found
 259            (unless (mapc
 260                     (lambda (project)
 261                       (let ((name (car project))
 262                             (run (plist-get (cdr project) :on-hit))
 263                             (root (project-root-get-root (cdr project))))
 264                         (when root
 265                           (when (and root (not dont-run-on-hit) run)
 266                             (funcall run (cons name root)))
 267                           (throw 'root-found (cons name root)))))
 268                     project-roots)
 269              nil))))
 270     ;; set the actual var used by apps and add to the global project
 271     ;; list
 272     (when (setq project-details project)
 273       (add-to-list 'project-root-seen-projects project))))
 274
 275 (defun project-root-every (pred seq)
 276   "Return non-nil if pred of each element, of seq is non-nil."
 277   (catch 'got-nil
 278     (mapc (lambda (x)
 279             (unless (funcall pred x)
 280               (throw 'got-nil nil)))
 281           seq)))
 282
 283 (defun project-root-upward-find-files (filenames &optional startdir)
 284   "Return the first directory upwards from STARTDIR that contains
 285 all elements of FILENAMES. If STATDIR is nil then use
 286 current-directory."
 287   (let ((default-directory (expand-file-name (or startdir ".")))
 288         (depth 0))
 289     (catch 'pr-finish
 290       (while t
 291         ;; don't go too far down the tree
 292         (when (> (setq depth (1+ depth)) project-root-max-search-depth)
 293           (throw 'pr-finish nil))
 294         (cond
 295           ((project-root-every 'file-exists-p filenames)
 296            (throw 'pr-finish default-directory))
 297           ;; if we hit root
 298           ((string= (expand-file-name default-directory) "/")
 299            (throw 'pr-finish nil)))
 300         ;; try again up a directory
 301         (setq default-directory
 302               (expand-file-name ".." default-directory))))))
 303
 304 (defun project-root-p (&optional p)
 305   "Check to see if P or `project-details' is valid"
 306   (let ((p (or p project-details)))
 307     (and p (file-exists-p (cdr p)))))
 308
 309 (defmacro with-project-root (&rest body)
 310   "Run BODY with default-directory set to the project root. Error
 311 if not found. If `project-root' isn't defined then try and find
 312 one."
 313   (declare (indent 2))
 314   `(progn
 315      (unless project-details (project-root-fetch))
 316      (if (project-root-p)
 317         (let ((default-directory (cdr project-details)))
 318           ,@body)
 319        (error "No project root found"))))
 320
 321 (defun project-root-goto-root ()
 322   "Open up the project root in dired."
 323   (interactive)
 324   (with-project-root (find-file (cdr project-details))))
 325
 326 (defun project-root-grep ()
 327   "Run the grep command from the current project root."
 328   (interactive)
 329   (with-project-root (call-interactively 'grep)))
 330
 331 (defun project-root-ack ()
 332   "Run the ack command from the current project root (if ack is
 333 avalible)."
 334   (interactive)
 335   (with-project-root
 336     (if (fboundp 'ack)
 337         (call-interactively 'ack)
 338         (error "`ack' not bound"))))
 339
 340 (defun project-root-find-file ()
 341   "Find a file from a list of those that exist in the current
 342 project."
 343   (interactive)
 344   (with-project-root (call-interactively 'find-file)))
 345
 346 (defun project-root-execute-extended-command ()
 347   "Run `execute-extended-command' after having set
 348 `default-directory' to the root of the current project."
 349   (interactive)
 350   (with-project-root (execute-extended-command current-prefix-arg)))
 351
 352 (defun project-root-file-in-project (filename &optional p)
 353   "Check to see if FILENAME is in the project P. If P is omitted
 354 then the current project-details are used."
 355   (let ((p (or p (progn
 356                    (project-root-fetch)
 357                    project-details))))
 358     (and
 359      p
 360      (file-exists-p filename)
 361      (not (null (string-match
 362                  (regexp-quote (abbreviate-file-name (cdr p)))
 363                  filename))))))
 364
 365 ;;; anything.el config
 366
 367 (defun project-root-anything-colourfy-hits (hits)
 368   ;; delete the project-root part
 369   (let ((highs (project-root-data :anything-highlight
 370                                   anything-project-root)))
 371     (mapcar
 372      (lambda (hit)
 373        (let ((new (replace-regexp-in-string
 374                   (regexp-quote (cdr anything-project-root))
 375                   ""
 376                   hit)))
 377         (when highs
 378           (mapc (lambda (s)
 379                   ;; propertize either the first group or the whole
 380                   ;; string
 381                   (when (string-match (car s) new)
 382                     (put-text-property (or (match-beginning 1) 0)
 383                                        (or (match-end 1) (length new))
 384                                        'face (cdr s)
 385                                        new)))
 386                 highs))
 387         (cons new hit)))
 388      hits)))
 389
 390 (defvar project-root-anything-config-files
 391   '((name . "Project Files")
 392     (init . (lambda ()
 393               (unless project-details
 394                 (project-root-fetch))
 395               (setq anything-project-root project-details)))
 396     (candidates . (lambda ()
 397                     (project-root-file-find-process anything-pattern)))
 398     (candidate-transformer . project-root-anything-colourfy-hits)
 399     (type . file)
 400     (requires-pattern . 2)
 401     (volatile)
 402     (delayed)))
 403
 404 (defvar project-root-anything-config-bookmarks
 405   '((name . "Project Bookmarks")
 406     (init . (lambda ()
 407               (unless project-details
 408                 (project-root-fetch))
 409               (setq anything-default-directory (cdr project-details)
 410                     anything-project-root project-details)))
 411     (candidates . (lambda ()
 412                     (mapcar
 413                      (lambda (b)
 414                       (expand-file-name b anything-default-directory))
 415                      (project-root-bookmarks anything-project-root))))
 416     (type . file)))
 417
 418 (defun project-root-file-find-process (pattern)
 419   "Return a process which represents a find of all files matching
 420 `project-root-extra-find-args' and the hard-coded arguments in
 421 this function."
 422   (when anything-project-root
 423       (start-process-shell-command "project-root-find"
 424                                    nil
 425                                    "find"
 426                                    (cdr anything-project-root)
 427                                    (find-to-string
 428                                     `(and ,project-root-extra-find-args
 429                                           (name ,(concat "*" pattern "*"))
 430                                           (type "f"))))))
 431
 432 (provide 'project-root)