Skip to content
Branch: master
Find file Copy path
Find file Copy path
779 lines (671 sloc) 27.1 KB
;;; dired-subtree.el --- Insert subdirectories in a tree-like fashion
;; Copyright (C) 2014-2015 Matúš Goljer
;; Author: Matúš Goljer <>
;; Maintainer: Matúš Goljer <>
;; Keywords: files
;; Version: 0.0.1
;; Created: 25th February 2014
;; Package-requires: ((dash "2.5.0") (dired-hacks-utils "0.0.1"))
;; 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 of the License, 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. If not, see <>.
;;; Commentary:
;; Introduction
;; ------------
;; The basic command to work with subdirectories in dired is `i',
;; which inserts the subdirectory as a separate listing in the active
;; dired buffer.
;; This package defines function `dired-subtree-insert' which instead
;; inserts the subdirectory directly below its line in the original
;; listing, and indent the listing of subdirectory to resemble a
;; tree-like structure (somewhat similar to tree(1) except the pretty
;; graphics). The tree display is somewhat more intuitive than the
;; default "flat" subdirectory manipulation provided by `i'.
;; There are several presentation options and faces you can customize
;; to change the way subtrees are displayed.
;; You can further remove the unwanted lines from the subtree by using
;; `k' command or some of the built-in "focusing" functions, such as
;; `dired-subtree-only-*' (see list below).
;; If you have the package `dired-filter', you can additionally filter
;; the subtrees with global or local filters.
;; A demo of basic functionality is available on youtube:
;; Interactive functions
;; ---------------------
;; Here's a list of available interactive functions. You can read
;; more about each one by using the built-in documentation facilities
;; of emacs. It is adviced to place bindings for these into a
;; convenient prefix key map, for example C-,
;; * `dired-subtree-insert'
;; * `dired-subtree-remove'
;; * `dired-subtree-toggle'
;; * `dired-subtree-cycle'
;; * `dired-subtree-revert'
;; * `dired-subtree-narrow'
;; * `dired-subtree-up'
;; * `dired-subtree-down'
;; * `dired-subtree-next-sibling'
;; * `dired-subtree-previous-sibling'
;; * `dired-subtree-beginning'
;; * `dired-subtree-end'
;; * `dired-subtree-mark-subtree'
;; * `dired-subtree-unmark-subtree'
;; * `dired-subtree-only-this-file'
;; * `dired-subtree-only-this-directory'
;; If you have package `dired-filter', additional command
;; `dired-subtree-apply-filter' is available.
;; See for the entire collection.
;;; Code:
(require 'dired-hacks-utils)
(require 'dash)
(require 'cl-lib)
(defgroup dired-subtree ()
"Insert subdirectories in a tree-like fashion."
:group 'dired-hacks
:prefix "dired-subtree-")
(defcustom dired-subtree-line-prefix " "
"A prefix put into each nested subtree.
The prefix is repeated \"depth\" times.
Alternatively, it can be a function taking one argument---the
depth---that creates the prefix."
:type '(choice string function)
:group 'dired-subtree)
(defcustom dired-subtree-line-prefix-face 'parents
"Specifies how the prefix is fontified."
:type '(radio
(const :tag "No face applied" nil)
(const :tag "Inherit from current subtree" subtree)
(const :tag "Inherit from all parents" parents))
:group 'dired-subtree)
(defcustom dired-subtree-use-backgrounds t
"When non-nil, add a background face to a subtree listing."
:type 'boolean
:group 'dired-subtree)
(defcustom dired-subtree-after-insert-hook ()
"Hook run at the end of `dired-subtree-insert'."
:type 'hook
:group 'dired-subtree)
(defcustom dired-subtree-after-remove-hook ()
"Hook run at the end of `dired-subtree-remove'."
:type 'hook
:group 'dired-subtree)
(defcustom dired-subtree-cycle-depth 3
"Default depth expanded by `dired-subtree-cycle'."
:type 'integer
:group 'dired-subtree)
(defcustom dired-subtree-ignored-regexp
(concat "^" (regexp-opt vc-directory-exclusion-list) "$")
"Matching directories will not be expanded in `dired-subtree-cycle'."
:type 'string
:group 'dired-subtree)
(defgroup dired-subtree-faces ()
"Faces used in `dired-subtree'."
:group 'dired-subtree)
(defface dired-subtree-depth-1-face
'((t (:background "#252e30")))
"Background for depth 1 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-2-face
'((t (:background "#232a2b")))
"Background for depth 2 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-3-face
'((t (:background "#212627")))
"Background for depth 3 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-4-face
'((t (:background "#1e2223")))
"Background for depth 4 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-5-face
'((t (:background "#1c1d1e")))
"Background for depth 5 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-6-face
'((t (:background "#1a191a")))
"Background for depth 6 subtrees"
:group 'dired-subtree-faces)
(defvar dired-subtree-overlays nil
"Subtree overlays in this buffer.")
(make-variable-buffer-local 'dired-subtree-overlays)
;;; Overlay manipulation
;; Maybe we should abstract the overlay-foo into some subtree
;; functions instead!!!
(defun dired-subtree--remove-overlay (ov)
"Remove dired-subtree overlay OV."
(setq dired-subtree-overlays
(--remove (equal it ov) dired-subtree-overlays))
(delete-overlay ov))
(defun dired-subtree--remove-overlays (ovs)
"Remove dired-subtree overlays OVS."
(mapc 'dired-subtree--remove-overlay ovs))
(defun dired-subtree--cleanup-overlays ()
"Remove the `nil' values from `dired-subtree-overlays'."
(setq dired-subtree-overlays
(--remove (not (overlay-buffer it)) dired-subtree-overlays)))
(defun dired-subtree--get-all-ovs ()
"Get all dired-subtree overlays in this buffer."
(--filter (overlay-get it 'dired-subtree-depth) (overlays-in (point-min) (point-max))))
(defun dired-subtree--get-all-ovs-at-point (&optional p)
"Get all dired-subtree overlays at point P."
(setq p (or p (point)))
(--filter (overlay-get it 'dired-subtree-depth) (overlays-at (point))))
(defun dired-subtree--get-ovs-in (&optional beg end)
"Get all dired-subtree overlays between BEG and END.
BEG and END default to the region spanned by overlay at point."
(when (not beg)
(let ((ov (dired-subtree--get-ov)))
(setq beg (overlay-start ov))
(setq end (overlay-end ov))))
(--filter (and (overlay-get it 'dired-subtree-depth)
(>= (overlay-start it) beg)
(<= (overlay-end it) end))
(overlays-in (point-min) (point-max))))
(defun dired-subtree--get-ov (&optional p)
"Get the parent subtree overlay at point."
(setq p (or p (point)))
(car (--sort (> (overlay-get it 'dired-subtree-depth)
(overlay-get other 'dired-subtree-depth))
(dired-subtree--get-all-ovs-at-point p))))
(defun dired-subtree--get-depth (ov)
"Get subtree depth."
(or (and ov (overlay-get ov 'dired-subtree-depth)) 0))
;;; helpers
(defvar dired-subtree-preserve-properties '(dired-subtree-filter)
"Properties that should be preserved between read-ins.")
(defun dired-subtree--after-readin (&optional subtrees)
"Insert the SUBTREES again after dired buffer has been reverted.
If no SUBTREES are specified, use `dired-subtree-overlays'."
(-when-let (subtrees-to-process (or subtrees dired-subtree-overlays))
(let* ((ovs-by-depth (--sort (< (car it) (car other))
(--group-by (overlay-get it 'dired-subtree-depth)
(sorted-ovs (--map (cons (car it)
(--map (-cons* it
(overlay-get it 'dired-subtree-name)
(-map (lambda (x) (cons x (overlay-get it x)))
dired-subtree-preserve-properties)) (cdr it)))
;; (depth (path1 ov1 (prop1 . value1) (prop2 . value2)) (path2 ...))
(--each sorted-ovs
(--each (cdr it)
(when (dired-utils-goto-line (cadr it))
(dired-subtree--remove-overlay (car it))
(let ((ov (dired-subtree--get-ov)))
(--each (cddr it)
(overlay-put ov (car it) (cdr it)))
(dired-subtree--filter-subtree ov))))))))
(defun dired-subtree--after-insert ()
"After inserting the subtree, setup dired-details/dired-hide-details-mode."
(if (fboundp 'dired-insert-set-properties)
(let ((inhibit-read-only t)
(ov (dired-subtree--get-ov)))
(dired-insert-set-properties (overlay-start ov) (overlay-end ov)))
(when (featurep 'dired-details)
(add-hook 'dired-after-readin-hook 'dired-subtree--after-readin)
(add-hook 'dired-subtree-after-insert-hook 'dired-subtree--after-insert)
(defun dired-subtree--unmark ()
"Unmark a file without moving point."
(save-excursion (dired-unmark 1)))
(defun dired-subtree--dired-line-is-directory-or-link-p ()
"Return non-nil if line under point is a directory or symlink"
;; We've replaced `file-directory-p' with the regexp test to
;; speed up filters over TRAMP. So long as dired/ls format
;; doesn't change, we're good.
;; 'd' for directories, 'l' for potential symlinks to directories.
(save-excursion (beginning-of-line) (looking-at "..[dl]")))
(defun dired-subtree--is-expanded-p ()
"Return non-nil if directory under point is expanded."
(when (dired-utils-get-filename)
(let ((depth (dired-subtree--get-depth (dired-subtree--get-ov))))
(dired-next-line 1)
(< depth (dired-subtree--get-depth (dired-subtree--get-ov)))))))
(defmacro dired-subtree-with-subtree (&rest forms)
"Run FORMS on each file in this subtree."
(declare (debug (body)))
(while (dired-subtree-next-sibling)
;;;; Interactive
(defun dired-subtree-narrow ()
"Narrow the buffer to this subtree."
(-when-let (ov (dired-subtree--get-ov))
(narrow-to-region (overlay-start ov)
(overlay-end ov))))
;;; Navigation
;; make the arguments actually do something
(defun dired-subtree-up (&optional arg)
"Jump up one directory."
(interactive "p")
(-when-let (ov (dired-subtree--get-ov))
(goto-char (overlay-start ov))
(dired-previous-line 1)))
(defun dired-subtree-down (&optional arg)
"Jump down one directory."
(interactive "p")
(-when-let* ((p (point))
(ov (car (--sort
(< (overlay-start it)
(overlay-start other))
(< (overlay-start it) p)
(goto-char (overlay-start ov))
(defun dired-subtree-next-sibling (&optional arg)
"Go to the next sibling."
(interactive "p")
(let ((current-ov (dired-subtree--get-ov)))
(dired-next-line 1)
(let ((new-ov (dired-subtree--get-ov)))
((not (dired-utils-is-file-p))
((< (dired-subtree--get-depth current-ov)
(dired-subtree--get-depth new-ov))
(goto-char (overlay-end new-ov))
((> (dired-subtree--get-depth current-ov)
(dired-subtree--get-depth new-ov))
;; add option to either go to top or stay at the end
(dired-previous-line 1)
(t t)))))
(defun dired-subtree-previous-sibling (&optional arg)
"Go to the previous sibling."
(interactive "p")
(let ((current-ov (dired-subtree--get-ov)))
(dired-previous-line 1)
(let ((new-ov (dired-subtree--get-ov)))
;; this will need better handlign if we have inserted
;; subdirectories
((not (dired-utils-is-file-p))
((< (dired-subtree--get-depth current-ov)
(dired-subtree--get-depth new-ov))
(goto-char (overlay-start new-ov))
(dired-previous-line 1)
((> (dired-subtree--get-depth current-ov)
(dired-subtree--get-depth new-ov))
;; add option to either go to top or stay at the end
(dired-next-line 1)
(t t)))))
(defun dired-subtree-beginning ()
"Go to the first file in this subtree."
(let ((ov (dired-subtree--get-ov)))
(if (not ov)
;; do something when not in subtree
(goto-char (overlay-start ov))
(defun dired-subtree-end ()
"Go to the first file in this subtree."
(let ((ov (dired-subtree--get-ov)))
(if (not ov)
;; do something when not in subtree
(goto-char (overlay-end ov))
(dired-previous-line 1))))
;;; Marking
(defun dired-subtree-mark-subtree (&optional all)
"Mark all files in this subtree.
With prefix argument mark all the files in subdirectories
(interactive "P")
(if all
(let ((beg (save-excursion
(end (save-excursion
(progn (goto-char beg) (line-beginning-position))
(progn (goto-char end) (line-end-position))))
(save-excursion (dired-mark 1))
(while (dired-subtree-next-sibling)
(save-excursion (dired-mark 1))))))
(defun dired-subtree-unmark-subtree (&optional all)
"Unmark all files in this subtree.
With prefix argument unmark all the files in subdirectories
(let ((dired-marker-char ? ))
(dired-subtree-mark-subtree all)))
;;; Insertion/deletion
(defun dired-subtree-revert ()
"Revert the subtree.
This means reinserting the content of this subtree and all its
(let ((inhibit-read-only t)
(file-name (dired-utils-get-filename)))
(-when-let* ((ov (dired-subtree--get-ov))
(ovs (dired-subtree--get-ovs-in)))
(delete-region (overlay-start ov) (overlay-end ov))
(dired-subtree--after-readin ovs)
(when file-name
(dired-utils-goto-line file-name)))))
(defun dired-subtree--readin (dir-name)
"Read in the directory.
Return a string suitable for insertion in `dired' buffer."
(insert-directory dir-name dired-listing-switches nil t)
(delete-char -1)
(goto-char (point-min))
(progn (beginning-of-line) (point))
(progn (forward-line
(if (save-excursion
(forward-line 1)
(looking-back "\\."))
3 1)) (point)))
(insert " ")
(while (= (forward-line) 0)
(insert " "))
(delete-char -2)
(defun dired-subtree-insert ()
"Insert subtree under this directory."
(when (and (dired-subtree--dired-line-is-directory-or-link-p)
(not (dired-subtree--is-expanded-p)))
(let* ((dir-name (dired-get-filename nil))
(listing (dired-subtree--readin (file-name-as-directory dir-name)))
beg end)
(read-only-mode -1)
(move-end-of-line 1)
;; this is pretty ugly, I'm sure it can be done better
(insert listing)
(setq end (+ (point) 2)))
(setq beg (point))
(let ((inhibit-read-only t))
(remove-text-properties (1- beg) beg '(dired-filename)))
(let* ((ov (make-overlay beg end))
(parent (dired-subtree--get-ov (1- beg)))
(depth (or (and parent (1+ (overlay-get parent 'dired-subtree-depth)))
(face (intern (format "dired-subtree-depth-%d-face" depth))))
(when dired-subtree-use-backgrounds
(overlay-put ov 'face face))
;; refactor this to some function
(overlay-put ov 'line-prefix
(if (stringp dired-subtree-line-prefix)
(if (not dired-subtree-use-backgrounds)
(apply 'concat (-repeat depth dired-subtree-line-prefix))
((eq nil dired-subtree-line-prefix-face)
(apply 'concat
(-repeat depth dired-subtree-line-prefix)))
((eq 'subtree dired-subtree-line-prefix-face)
(apply 'concat
(-repeat (1- depth) dired-subtree-line-prefix))
'face face)))
((eq 'parents dired-subtree-line-prefix-face)
(apply 'concat
(propertize dired-subtree-line-prefix
(intern (format "dired-subtree-depth-%d-face" it)))
(number-sequence 1 (1- depth))))))))
(funcall dired-subtree-line-prefix depth)))
(overlay-put ov 'dired-subtree-name dir-name)
(overlay-put ov 'dired-subtree-parent parent)
(overlay-put ov 'dired-subtree-depth depth)
(overlay-put ov 'evaporate t)
(push ov dired-subtree-overlays))
(goto-char beg)
(read-only-mode 1)
(run-hooks 'dired-subtree-after-insert-hook))))
(defun dired-subtree-remove ()
"Remove subtree at point."
(-when-let* ((ov (dired-subtree--get-ov))
(ovs (dired-subtree--get-ovs-in
(overlay-start ov)
(overlay-end ov))))
(let ((inhibit-read-only t))
(delete-region (overlay-start ov)
(overlay-end ov))
(dired-subtree--remove-overlays ovs)))
(run-hooks 'dired-subtree-after-remove-hook))
(defun dired-subtree-toggle ()
"Insert subtree at point or remove it if it was not present."
(if (dired-subtree--is-expanded-p)
(dired-next-line 1)
(save-excursion (dired-subtree-insert))))
(defun dired-subtree--insert-recursive (depth max-depth)
"Insert full subtree at point."
(let ((name (dired-get-filename nil t)))
(when (and name (file-directory-p name)
(<= depth (or max-depth depth))
(or (= 1 depth)
(not (string-match-p dired-subtree-ignored-regexp
(file-name-nondirectory name)))))
(if (dired-subtree--is-expanded-p)
(dired-next-line 1)
(dired-subtree--insert-recursive (1+ depth) max-depth)
(while (dired-subtree-previous-sibling)
(dired-subtree--insert-recursive (1+ depth) max-depth))))))
(defvar dired-subtree--cycle-previous nil
"Remember previous action for `dired-subtree-cycle'")
(defun dired-subtree-cycle (&optional max-depth)
"Org-mode like cycle visibility:
1) Show subtree
2) Show subtree recursively (if previous command was cycle)
3) Remove subtree
Numeric prefix will set max depth"
(interactive "P")
;; prefix - show subtrees up to max-depth
(when (dired-subtree--is-expanded-p)
(dired-next-line 1)
(dired-subtree--insert-recursive 1 (if (integerp max-depth) max-depth nil))
(setq dired-subtree--cycle-previous :full))
;; if directory is not expanded, expand one level
((not (dired-subtree--is-expanded-p))
(setq dired-subtree--cycle-previous :insert))
;; hide if previous command was not cycle or tree was fully expanded
((or (not (eq last-command 'dired-subtree-cycle))
(eq dired-subtree--cycle-previous :full))
(dired-next-line 1)
(setq dired-subtree--cycle-previous :remove))
(dired-subtree--insert-recursive 1 dired-subtree-cycle-depth)
(setq dired-subtree--cycle-previous :full)))))
(defun dired-subtree--filter-up (keep-dir kill-siblings)
(let (ov)
(while (dired-subtree-up))
(dired-next-line 1)
(dired-subtree-mark-subtree t))
(if keep-dir
(while (and (dired-subtree-up)
(> (dired-subtree--get-depth (dired-subtree--get-ov)) 0))
(if (not kill-siblings)
(let ((here (point)))
(when (and (dired-subtree--is-expanded-p)
(/= (point) here))
(dired-next-line 1)
(dired-subtree-unmark-subtree t)))))))
(defun dired-subtree-only-this-file (&optional arg)
"Remove all the siblings on the route from this file to the top-most directory.
With ARG non-nil, do not remove expanded directories in parents."
(interactive "P")
(dired-subtree--filter-up nil arg))
(defun dired-subtree-only-this-directory (&optional arg)
"Remove all the siblings on the route from this directory to the top-most directory.
With ARG non-nil, do not remove expanded directories in parents."
(interactive "P")
(dired-subtree--filter-up t arg))
;;; filtering
(defun dired-subtree--filter-update-bs (ov)
"Update the local filter list.
This function assumes that `dired-filter-stack' is dynamically
bound to relevant value."
(let* ((filt (dired-filter--describe-filters))
(before-str (if (equal filt "") nil (concat " Local filters: " filt "\n"))))
(overlay-put ov 'before-string before-str)))
(defun dired-subtree--filter-subtree (ov)
"Run the filter for this subtree.
It is only safe to call this from readin.
This depends on `dired-filter' package."
(when (featurep 'dired-filter)
(let ((dired-filter-stack (overlay-get ov 'dired-subtree-filter)))
(dired-subtree--filter-update-bs ov)))))
(defun dired-subtree-apply-filter ()
"Push a local filter for this subtree.
This depends on `dired-filter' package.
It works exactly the same as global dired filters, only
restricted to a subtree. The global filter is also applied to
the subtree. The filter action is read from `dired-filter-map'."
(when (featurep 'dired-filter)
(-when-let (ov (dired-subtree--get-ov))
(let ((dired-filter-stack (overlay-get ov 'dired-subtree-filter))
(glob (current-global-map))
(loc (current-local-map))
(cl-flet ((dired-filter--update
(overlay-put ov 'dired-subtree-filter dired-filter-stack)
(dired-subtree--filter-update-bs ov))))
(use-global-map dired-filter-map)
(use-local-map nil)
(setq cmd (key-binding (read-key-sequence "Choose filter action: "))))
(use-global-map glob)
(use-local-map loc))
(let ((p (point))
(beg (overlay-start ov))
(current-file (dired-utils-get-filename)))
(call-interactively cmd)
(unless (dired-utils-goto-line current-file)
(goto-char beg)
(goto-char (min p (1- (overlay-end (dired-subtree--get-ov)))))
;;; Here we redefine a couple of functions from dired.el to make them
;;; subtree-aware
;; If the point is in a subtree, we need to provide a proper
;; directory, not the one that would come from `dired-subdir-alist'.
(defun dired-current-directory (&optional localp)
"Return the name of the subdirectory to which this line belongs.
This returns a string with trailing slash, like `default-directory'.
Optional argument means return a file name relative to `default-directory'."
(let ((here (point))
(alist (or dired-subdir-alist
;; probably because called in a non-dired buffer
(error "No subdir-alist in %s" (current-buffer))))
elt dir)
(while alist
(setq elt (car alist)
dir (car elt)
;; use `<=' (not `<') as subdir line is part of subdir
alist (if (<= (dired-get-subdir-min elt) here)
nil ; found
(cdr alist))))
;; dired-subdir: modify dir here if we are in a "subtree" view
(-when-let (parent (dired-subtree--get-ov))
(setq dir (concat (overlay-get parent 'dired-subtree-name) "/")))
;; end
(if localp
(dired-make-relative dir default-directory)
;; Since the tree-inserted directory is not in the dired-subdir-alist,
;; we need to guard against nil.
(defun dired-get-subdir ()
;;"Return the subdir name on this line, or nil if not on a headerline."
;; Look up in the alist whether this is a headerline.
(let ((cur-dir (dired-current-directory)))
(beginning-of-line) ; alist stores b-o-l positions
(and (zerop (- (point)
(or (dired-get-subdir-min
(assoc cur-dir
0))) ;; dired-subtree: return zero if current
;; dir is not in `dired-subdir-alist'.
(provide 'dired-subtree)
;;; dired-subtree.el ends here
You can’t perform that action at this time.