;;; 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 ;; 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 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: ;; https://www.youtube.com/watch?v=z26b8HKFsNE ;; 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 https://github.com/Fuco1/dired-hacks 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 'natnum :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 'regexp :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) subtrees-to-process))) (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))) ovs-by-depth))) ;; (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)) (dired-subtree-insert) (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) (dired-details-delete-overlays) (dired-details-activate)))) (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." (save-excursion (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))) `(save-excursion (dired-subtree-beginning) ,@forms (while (dired-subtree-next-sibling) ,@forms))) ;;;; Interactive ;;;###autoload (defun dired-subtree-narrow () "Narrow the buffer to this subtree." (interactive) (-when-let (ov (dired-subtree--get-ov)) (narrow-to-region (overlay-start ov) (overlay-end ov)))) ;;; Navigation ;; make the arguments actually do something ;;;###autoload (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))) ;;;###autoload (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)) (--remove (< (overlay-start it) p) (dired-subtree--get-all-ovs)))))) (goto-char (overlay-start ov)) (dired-move-to-filename))) ;;;###autoload (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))) (cond ((not (dired-utils-is-file-p)) nil) ((< (dired-subtree--get-depth current-ov) (dired-subtree--get-depth new-ov)) (goto-char (overlay-end new-ov)) (dired-move-to-filename) t) ((> (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) nil) (t t))))) ;;;###autoload (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))) (cond ;; this will need better handlign if we have inserted ;; subdirectories ((not (dired-utils-is-file-p)) nil) ((< (dired-subtree--get-depth current-ov) (dired-subtree--get-depth new-ov)) (goto-char (overlay-start new-ov)) (dired-previous-line 1) t) ((> (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) nil) (t t))))) ;;;###autoload (defun dired-subtree-beginning () "Go to the first file in this subtree." (interactive) (let ((ov (dired-subtree--get-ov))) (if (not ov) ;; do something when not in subtree t (goto-char (overlay-start ov)) (dired-move-to-filename)))) ;;;###autoload (defun dired-subtree-end () "Go to the first file in this subtree." (interactive) (let ((ov (dired-subtree--get-ov))) (if (not ov) ;; do something when not in subtree t (goto-char (overlay-end ov)) (dired-previous-line 1)))) ;;; Marking ;;;###autoload (defun dired-subtree-mark-subtree (&optional all) "Mark all files in this subtree. With prefix argument mark all the files in subdirectories recursively." (interactive "P") (save-excursion (if all (let ((beg (save-excursion (dired-subtree-beginning) (point))) (end (save-excursion (dired-subtree-end) (point)))) (dired-mark-files-in-region (progn (goto-char beg) (line-beginning-position)) (progn (goto-char end) (line-end-position)))) (dired-subtree-beginning) (save-excursion (dired-mark 1)) (while (dired-subtree-next-sibling) (save-excursion (dired-mark 1)))))) ;;;###autoload (defun dired-subtree-unmark-subtree (&optional all) "Unmark all files in this subtree. With prefix argument unmark all the files in subdirectories recursively." (interactive) (let ((dired-marker-char ? )) (dired-subtree-mark-subtree all))) ;;; Insertion/deletion ;;;###autoload (defun dired-subtree-revert () "Revert the subtree. This means reinserting the content of this subtree and all its children." (interactive) (let ((inhibit-read-only t) (file-name (dired-utils-get-filename))) (-when-let* ((ov (dired-subtree--get-ov)) (ovs (dired-subtree--get-ovs-in))) (dired-subtree-up) (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." (with-temp-buffer (insert-directory dir-name dired-listing-switches nil t) (delete-char -1) (goto-char (point-min)) (delete-region (progn (beginning-of-line) (point)) (progn (forward-line (if (save-excursion (forward-line 1) (end-of-line) (looking-back "\\.")) 3 1)) (point))) (insert " ") (while (= (forward-line) 0) (insert " ")) (delete-char -2) (buffer-string))) ;;;###autoload (defun dired-subtree-insert () "Insert subtree under this directory." (interactive) (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 (save-excursion (insert listing) (setq end (+ (point) 2))) (newline) (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))) 1)) (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)) (cond ((eq nil dired-subtree-line-prefix-face) (apply 'concat (-repeat depth dired-subtree-line-prefix))) ((eq 'subtree dired-subtree-line-prefix-face) (concat dired-subtree-line-prefix (propertize (apply 'concat (-repeat (1- depth) dired-subtree-line-prefix)) 'face face))) ((eq 'parents dired-subtree-line-prefix-face) (concat dired-subtree-line-prefix (apply 'concat (--map (propertize dired-subtree-line-prefix 'face (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) (dired-move-to-filename) (read-only-mode 1) (when (bound-and-true-p dired-filter-mode) (dired-filter-mode 1)) (run-hooks 'dired-subtree-after-insert-hook)))) ;;;###autoload (defun dired-subtree-remove () "Remove subtree at point." (interactive) (-when-let* ((ov (dired-subtree--get-ov)) (ovs (dired-subtree--get-ovs-in (overlay-start ov) (overlay-end ov)))) (let ((inhibit-read-only t)) (dired-subtree-up) (delete-region (overlay-start ov) (overlay-end ov)) (dired-subtree--remove-overlays ovs))) (run-hooks 'dired-subtree-after-remove-hook)) ;;;###autoload (defun dired-subtree-toggle () "Insert subtree at point or remove it if it was not present." (interactive) (if (dired-subtree--is-expanded-p) (progn (dired-next-line 1) (dired-subtree-remove) ;; #175 fixes the case of the first line in dired when the ;; cursor jumps to the header in dired rather then to the ;; first file in buffer (when (bobp) (dired-next-line 1))) (save-excursion (dired-subtree-insert)))) (defun dired-subtree--insert-recursive (depth max-depth) "Insert full subtree at point." (save-excursion (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)) (dired-subtree-end) (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'") ;;;###autoload (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") (save-excursion (cond ;; prefix - show subtrees up to max-depth (max-depth (when (dired-subtree--is-expanded-p) (dired-next-line 1) (dired-subtree-remove)) (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)) (dired-subtree-insert) (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) (dired-subtree-remove) (setq dired-subtree--cycle-previous :remove)) (t (dired-subtree--insert-recursive 1 dired-subtree-cycle-depth) (setq dired-subtree--cycle-previous :full))))) (defun dired-subtree--filter-up (keep-dir kill-siblings) (save-excursion (let (ov) (save-excursion (while (dired-subtree-up)) (dired-next-line 1) (dired-subtree-mark-subtree t)) (if keep-dir (dired-subtree-unmark-subtree) (dired-subtree--unmark)) (while (and (dired-subtree-up) (> (dired-subtree--get-depth (dired-subtree--get-ov)) 0)) (if (not kill-siblings) (dired-subtree--unmark) (dired-subtree--unmark) (let ((here (point))) (dired-subtree-with-subtree (when (and (dired-subtree--is-expanded-p) (/= (point) here)) (dired-subtree--unmark) (save-excursion (dired-next-line 1) (dired-subtree-unmark-subtree t))))))) (dired-do-kill-lines) (dired-subtree--cleanup-overlays)))) ;;;###autoload (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)) ;;;###autoload (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))) (save-restriction (widen) (dired-subtree-narrow) (dired-filter--expunge) (dired-subtree--filter-update-bs ov))))) ;;;###autoload (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'." (interactive) (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)) cmd) (cl-flet ((dired-filter--update () (save-restriction (overlay-put ov 'dired-subtree-filter dired-filter-stack) (widen) (dired-subtree-revert) (dired-subtree--filter-update-bs ov)))) (unwind-protect (progn (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))) (unwind-protect (call-interactively cmd) (unless (dired-utils-goto-line current-file) (goto-char beg) (forward-line) (goto-char (min p (1- (overlay-end (dired-subtree--get-ov))))) (dired-move-to-filename))))))))) ;;; 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) dir))) ;; 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. (save-excursion (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 dired-subdir-alist)) 0))) ;; dired-subtree: return zero if current ;; dir is not in `dired-subdir-alist'. cur-dir)))) (provide 'dired-subtree) ;;; dired-subtree.el ends here