;;; fiplr.el --- Fuzzy finder for files in a project.

;; Copyright © 2013 Chris Corbyn
;;
;; Author: Chris Corbyn <chris@w3style.co.uk>
;; URL: https://github.com/d11wtq/fiplr
;; Version: 0.1.3
;; Keywords: convenience, usability, project

;; This file is not part of GNU Emacs.

;;; --- License

;; Licensed under the same terms as Emacs.

;;; --- Commentary

;; Overview:
;;
;; Fiplr makes it really use to find files anywhere within your entire project
;; by using a cached directory tree and delegating to ido while you search the
;; tree.
;;
;;   M-x fiplr-find-file
;;
;; By default it looks through all the parent directories of the file you're
;; editing until it finds a .git, .hg, .bzr or .svn directory. You can
;; customize this list of root markers by setting `fiplr-root-markers'.
;;
;;   (setq fiplr-root-markers '(".git" ".svn"))
;;
;; Some files are ignored from the directory tree because they are not text
;; files, or simply to speed up the search. The default list can be
;; customized by setting `fiplr-ignored-globs'.
;;
;;   (setq fiplr-ignored-globs '((directories (".git" ".svn"))
;;                               (files ("*.jpg" "*.png" "*.zip" "*~"))))
;;
;; These globs are used by the UNIX `find' command's -name flag.
;;
;; Usage:
;;
;;   Find files:        M-x fiplr-find-file
;;   Find directories:  M-x fiplr-find-directory
;;   Clear caches:      M-x fiplr-clear-cache
;;
;; For convenience, bind "C-x f" to `fiplr-find-file':
;;
;;   (global-set-key (kbd "C-x f") 'fiplr-find-file)
;;

(require 'cl)

;;; --- Package Configuration

;; A cache to avoid repeat searching.
(setq *fiplr-file-cache* '())

;; A cache to avoid repeat searching.
(setq *fiplr-directory-cache* '())

;; The default set of files/directories to look for at the root of a project.
(defvar *fiplr-default-root-markers*
  '(".git" ".svn" ".hg" ".bzr"))

;; The default set of patterns to exclude from searches.
(defvar *fiplr-default-ignored-globs*
  '((directories (".git" ".svn" ".hg" ".bzr"))
    (files (".#*" "*.so"))))

;; Customization group declaration.
(defgroup fiplr nil
  "Configuration options for fiplr - find in project.")

;; Settings for project root directories.
(defcustom fiplr-root-markers *fiplr-default-root-markers*
  "A list of files or directories that are found at the root of a project."
  :type    '(repeat string)
  :group   'fiplr
  :options *fiplr-default-root-markers*)

;; Settings for files and directories that should be ignored.
(defcustom fiplr-ignored-globs *fiplr-default-ignored-globs*
  "An alist of glob patterns to exclude from search results."
  :type    '(alist :key-type symbol :value-type (repeat string))
  :group   'fiplr
  :options *fiplr-default-ignored-globs*)

;;; --- Public Functions

;; Defines fiplr's determination of the project root.
;;;###autoload
(defun fiplr-root ()
  "Locate the root of the project by walking up the directory tree."
  "The first directory containing one of fiplr-root-markers is the root."
  "If no root marker is found, the current working directory is used."
  (let ((cwd (if (buffer-file-name)
                 (directory-file-name
                  (file-name-directory (buffer-file-name)))
               (file-truename "."))))
    (or (fiplr-find-root cwd fiplr-root-markers)
        cwd)))

;; Locate a file in the current project.
;;;###autoload
(defun fiplr-find-file ()
  "Runs a completing prompt to find a file from the project."
  "The root of the project is the return value of `fiplr-root'."
  (interactive)
  (fiplr-find-file-in-directory (fiplr-root) fiplr-ignored-globs))

;; Locate a directory in the current project.
;;;###autoload
(defun fiplr-find-directory ()
  "Runs a completing prompt to find a directory from the project."
  "The root of the project is the return value of `fiplr-root'."
  (interactive)
  (fiplr-find-directory-in-directory (fiplr-root) fiplr-ignored-globs))

;; Clear the caches.
;;;###autoload
(defun fiplr-clear-cache ()
  "Clears the internal caches used by fiplr so the project is searched again."
  (interactive)
  (setq *fiplr-file-cache* '())
  (setq *fiplr-directory-cache* '()))

;;; --- Private Functions

;; Search algorithm to find dir with .git etc.
(defun fiplr-find-root (path root-markers)
  "Tail-recursive part of project-root."
  (let* ((this-dir (file-name-as-directory (file-truename path)))
         (parent-dir (expand-file-name (concat this-dir "..")))
         (system-root-dir (expand-file-name "/")))
    (cond
     ((fiplr-root-p path root-markers) this-dir)
     ((equal system-root-dir this-dir) nil)
     (t (fiplr-find-root parent-dir root-markers)))))

;; Predicate looking at path for a root marker.
(defun fiplr-root-p (path root-markers)
  "Predicate to check if the given directory is a project root."
  (let ((dir (file-name-as-directory path)))
    (cl-member-if (lambda (marker)
                    (file-exists-p (concat dir marker)))
                  root-markers)))

;; Builds a gigantic `find' shell command with -prune, -o, -not and shit.
(defun fiplr-list-files-shell-command (type path ignored-globs)
  "Builds the `find' command to locate all project files & directories."
  "Path is the base directory to recurse from."
  "Ignored-globs is an alist with keys 'directories and 'files."
  (let* ((type-abbrev
          (lambda (assoc-type)
            (cl-case assoc-type
              ('directories "d")
              ('files "f"))))
         (name-matcher
          (lambda (glob)
            (mapconcat 'identity
                       `("-name" ,(shell-quote-argument glob))
                       " ")))
         (grouped-name-matchers
          (lambda (type)
            (mapconcat 'identity
                       `(,(shell-quote-argument "(")
                         ,(mapconcat (lambda (v) (funcall name-matcher v))
                                     (cadr (assoc type ignored-globs))
                                     " -o ")
                         ,(shell-quote-argument ")"))
                       " ")))
         (matcher
          (lambda (assoc-type)
            (mapconcat 'identity
                       `(,(shell-quote-argument "(")
                         "-type"
                         ,(funcall type-abbrev assoc-type)
                         ,(funcall grouped-name-matchers assoc-type)
                         ,(shell-quote-argument ")"))
                       " "))))
    (mapconcat 'identity
               `("find"
                 ,(shell-quote-argument (directory-file-name path))
                 ,(funcall matcher 'directories)
                 "-prune"
                 "-o"
                 "-not"
                 ,(funcall matcher 'files)
                 "-type"
                 ,(funcall type-abbrev type)
                 "-print")
               " ")))

;; List all files found under the given path, ignoring ignored-globs.
(defun fiplr-list-files (type path ignored-globs)
  "Expands to a flat list of files/directories found under path."
  "The first parameter - type - is the symbol 'directories or 'files."
  (let* ((prefix (file-name-as-directory (file-truename path)))
         (prefix-length (length prefix))
         (list-string
          (shell-command-to-string (fiplr-list-files-shell-command
                                    type
                                    prefix
                                    ignored-globs))))
    (reverse (reduce (lambda (acc file)
                       (if (> (length file) prefix-length)
                           (cons (substring file prefix-length) acc)
                         acc))
                     (split-string list-string "[\r\n]+" t)
                     :initial-value '()))))

;; Runs the find file prompt for the specified path.
(defun fiplr-find-file-in-directory (path ignored-globs)
  "Locate a file under the specified directory."
  "If the directory has been searched previously, the cache is used."
  (let ((root-dir (file-name-as-directory path)))
    (unless (assoc root-dir *fiplr-file-cache*)
      (push (cons root-dir (fiplr-list-files 'files root-dir ignored-globs))
            *fiplr-file-cache*))
    (let* ((project-files (cdr (assoc root-dir *fiplr-file-cache*)))
           (prompt "Find project file: ")
           (file (ido-completing-read prompt project-files)))
      (find-file (concat root-dir file)))))

;; Runs the find directory prompt for the specified path.
(defun fiplr-find-directory-in-directory (path ignored-globs)
  "Locate a directory under the specified directory."
  "If the directory has been searched previously, the cache is used."
  (let ((root-dir (file-name-as-directory path)))
    (unless (assoc root-dir *fiplr-directory-cache*)
      (push (cons root-dir (fiplr-list-files 'directories root-dir ignored-globs))
            *fiplr-directory-cache*))
    (let* ((project-dirs (cdr (assoc root-dir *fiplr-directory-cache*)))
           (prompt "Find project directory: ")
           (dirname (ido-completing-read prompt project-dirs)))
      (condition-case nil
          (dired (concat root-dir dirname))
        (error (message (concat "Cannot open directory: " dirname)))))))

(provide 'fiplr)

;;; fiplr.el ends here