;;; dirtree.el --- Directory tree views
;;
;; Author: Mark Triggs <mst@dishevelled.net>
;;
;; This file 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 2, or (at your option)
;; any later version.
;;
;; This file 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; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;;
;; Commentary:
;;
;; This uses tree-widget to display a directory tree that you can quickly
;; navigate and use to find files.  Bind `dirtree-switch' to a key to use it.
;;
;;; Code:
;;

(require 'tree-widget)

(defvar dirtree-hide-directories "\\({arch}\\|\\.arch-ids\\|CVS\\)"
  "Don't expand directories matching this regular expression")

(defun dirtree-expandable-p (directory)
  (not (string-match dirtree-hide-directories directory)))


(defvar dirtree-directory-trees (make-hash-table :test #'equal))

(defun dirtree-directory-tree (directory &optional force)
  (when (or force (not (gethash directory dirtree-directory-trees)))
    (puthash directory (dirtree-build-directory-tree directory)
             dirtree-directory-trees))
  (gethash directory dirtree-directory-trees))


(defun dirtree-build-directory-tree (path &optional base)
  (let ((full-path (if base (concat base "/" path) path)))
    (if (file-directory-p full-path)
        `(tree-widget :open ,(dirtree-expandable-p full-path)
                      :tag ,path
                      ,@(mapcar (lambda (entry)
                                  (dirtree-build-directory-tree
                                   entry full-path))
                                (remove-if (lambda (entry)
                                             (string-match "^\\.+$" entry))
                                           (directory-files full-path))))
      `(tree-widget :tag ,(propertize path :full-path full-path)))))


(defun dirtree-insert-directory-tree (directory &optional reload)
  (widget-create
   'tree-widget :open t
   :no-leaf-handle ""
   :node (dirtree-directory-tree directory reload)))


(defun dirtree-normalise-directory (directory)
  (replace-regexp-in-string "/*$" "" directory))


(defvar dirtree-last-dir nil
  "The last directory viewed with dirtree.")


(defun dirtree-build-buffer (directory &optional reload)
  (setq dirtree-last-dir directory)
  (let ((window-configuration (current-window-configuration)))
    (let ((buffer (get-buffer-create "*dirtree*")))
      (with-current-buffer buffer
        (let ((inhibit-read-only t))
          (erase-buffer)
          (dirtree-insert-directory-tree directory reload)
          (dirtree-mode)
          (goto-char (point-min))
          (set (make-local-variable 'dirtree-root) directory)))
      buffer)))


(defun dirtree-switch (&optional directory)
  (interactive (list (if (or current-prefix-arg (not dirtree-last-dir))
                         (dirtree-normalise-directory
                          (expand-file-name
                           (read-directory-name "Directory? ")))
                       dirtree-last-dir)))
  (let ((window-configuration (current-window-configuration)))
    (delete-other-windows)
    (split-window-horizontally)
    (switch-to-buffer (or (and (not current-prefix-arg)
                               (get-buffer "*dirtree*"))
                          (dirtree-build-buffer directory)))
    (set (make-local-variable 'dirtree-window-configuration)
         window-configuration)))


(defun dirtree-find-file-at-point ()
  (interactive)
  (let ((file (get-text-property (1- (line-end-position)) :full-path)))
    (when file
      (dirtree-quit)
      (find-file file))))


(defun dirtree-quit ()
  (interactive)
  (set-window-configuration dirtree-window-configuration)
  (when (string= (buffer-name (current-buffer))
                 "*dirtree*")
    (bury-buffer)))


(defun dirtree-move-up-dir ()
  (interactive)
  (unless (string= dirtree-root "/")
    (setq dirtree-root (file-name-directory dirtree-root)))
  (dirtree-refresh t))


(defun dirtree-new-directory (&optional directory)
  (interactive (list (dirtree-normalise-directory
                      (expand-file-name
                       (read-directory-name "Directory? "
                                            dirtree-last-dir)
                       dirtree-last-dir))))
  (setq dirtree-root directory)
  (dirtree-refresh t))


(defun dirtree-refresh (&optional no-reload)
  (interactive)
  (let ((window-configuration dirtree-window-configuration))
    (dirtree-build-buffer dirtree-root (not no-reload))
    (set (make-local-variable 'dirtree-window-configuration)
         window-configuration)))


(defun dirtree-next-file ()
  (interactive)
  (next-line 1)
  (beginning-of-line)
  (search-forward-regexp "-[-,] " nil t)
  (goto-char (match-end 0)))

(defun dirtree-prev-file ()
  (interactive)
  (next-line -1)
  (beginning-of-line)
  (search-forward-regexp "-[-,] " nil t)
  (goto-char (match-end 0)))


(defvar dirtree-mode-map (make-sparse-keymap) "The keymap for dirtree")
(define-key dirtree-mode-map (kbd "RET") 'dirtree-find-file-at-point)
(define-key dirtree-mode-map (kbd "q") 'dirtree-quit)
(define-key dirtree-mode-map (kbd "^") 'dirtree-move-up-dir)
(define-key dirtree-mode-map (kbd "g") 'dirtree-refresh)
(define-key dirtree-mode-map (kbd "f") 'dirtree-new-directory)
(define-key dirtree-mode-map (kbd "TAB") 'widget-forward)
(define-key dirtree-mode-map [backtab] 'widget-backward)
(define-key dirtree-mode-map (kbd "n") 'dirtree-next-file)
(define-key dirtree-mode-map (kbd "p") 'dirtree-prev-file)

(define-derived-mode dirtree-mode fundamental-mode "dirtree"
  "Mode for showing directory trees."
  (use-local-map dirtree-mode-map)
  (setq buffer-read-only t))


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