1615 lines
79 KiB
EmacsLisp
1615 lines
79 KiB
EmacsLisp
;;; dirvish.el --- A modern file manager based on dired mode -*- lexical-binding: t -*-
|
|
;; Copyright (C) 2021-2025 Alex Lu
|
|
|
|
;; Author : Alex Lu <https://github.com/alexluigit>
|
|
;; Package-Version: 20250504.807
|
|
;; Package-Revision: d877433f957a
|
|
;; Keywords: files, convenience
|
|
;; Homepage: https://github.com/alexluigit/dirvish
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
;; Package-Requires: ((emacs "28.1") (compat "30"))
|
|
|
|
;; This file is not part of GNU Emacs.
|
|
|
|
;;; Commentary:
|
|
;; A minimalistic yet versatile file manager based on Dired.
|
|
;; This package gives Dired the following features:
|
|
;;
|
|
;; - Multiple window layouts
|
|
;; - Always available file preview
|
|
;; - Isolated sessions
|
|
;; - A modern and composable user interface
|
|
|
|
;;; Code:
|
|
|
|
(require 'dired)
|
|
(require 'compat)
|
|
|
|
;;;; User Options
|
|
|
|
(defgroup dirvish nil "A better Dired." :group 'dired)
|
|
|
|
(defcustom dirvish-attributes '(file-size)
|
|
"File attributes showing in file lines.
|
|
Dirvish ships with these attributes:
|
|
|
|
- `subtree-state': A indicator for directory expanding state.
|
|
- `nerd-icons' | `all-the-icons' | `vscode-icons': File icons.
|
|
- `collapse': Collapse unique nested paths.
|
|
- `git-msg': Append git commit message to filename.
|
|
- `vc-state': The version control state at left fringe.
|
|
- `file-size': file size or directories file count at right fringe.
|
|
- `file-time': Show file modification time before the `file-size'."
|
|
:group 'dirvish :type '(repeat (symbol :tag "Dirvish attribute")))
|
|
|
|
(defcustom dirvish-preview-dispatchers
|
|
`(,(if (memq system-type '(ms-dos windows-nt)) 'video-mtn 'video)
|
|
image gif audio epub archive font pdf)
|
|
"List of preview dispatchers.
|
|
Each dispatcher in this list handles the validation and preview
|
|
content generation for the corresponding filetype.
|
|
|
|
The default value contains:
|
|
|
|
- image: preview image files, requires `vipsthumbnail'.
|
|
- gif: preview GIF image files with animation.
|
|
- video: preview videos files with thumbnail.
|
|
requires `ffmpegthumbnailer' on Linux/macOS | `mtn' on Windows
|
|
- audio: preview audio files with metadata, requires `mediainfo'.
|
|
- epub: preview epub documents, requires `epub-thumbnailer'.
|
|
- pdf: preview pdf with thumbnail generated by `pdftoppm'.
|
|
- font: preview font files, requires `magick'.
|
|
- archive: preview archives such as .tar, .zip, requires `7z' (`7zz' on macOS)."
|
|
:group 'dirvish :type '(repeat (symbol :tag "Dirvish preview methods")))
|
|
|
|
(defcustom dirvish-preview-disabled-exts '("bin" "exe" "gpg" "elc" "eln")
|
|
"Do not preview files end with these extensions."
|
|
:group 'dirvish :type '(repeat (string :tag "File name extension")))
|
|
|
|
(defcustom dirvish-preview-environment
|
|
'((inhibit-message . t) (non-essential . t)
|
|
(enable-dir-local-variables . nil) (enable-local-variables . :safe))
|
|
"Variables which are bound for default file preview dispatcher.
|
|
Credit: copied from `consult-preview-variables' in `consult.el'."
|
|
:group 'dirvish :type 'alist)
|
|
|
|
(defcustom dirvish-cache-dir
|
|
(expand-file-name "dirvish/" user-emacs-directory)
|
|
"Preview / thumbnail cache directory for dirvish."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-default-layout '(1 0.11 0.55)
|
|
"Default layout recipe for Dirvish sessions.
|
|
The value has the form (DEPTH MAX-PARENT-WIDTH PREVIEW-WIDTH).
|
|
|
|
- DEPTH controls the number of windows displaying parent directories, it
|
|
can be 0 if you don't need the parent directories.
|
|
- MAX-PARENT-WIDTH controls the max width allocated to each parent windows.
|
|
- PREVIEW-WIDTH controls the width allocated to preview window.
|
|
|
|
The default value provides a 1:3:5 (approximately) pane ratio. Also see
|
|
`dirvish-layout-recipes' in `dirvish-extras.el'.
|
|
|
|
Alternatively, set this to nil to hide both the parent and preview
|
|
windows. In this case, \\='(1 0.11 0.55) will be used as the fallback
|
|
full-frame recipe. This is useful when you want to use `dirvish'
|
|
exclusively for directory entries without `dired' or similar commands,
|
|
and want to prevent the preview from appearing at startup. You can
|
|
still use `dirvish-layout-toggle' or `dirvish-layout-switch' to display
|
|
the full-frame layout when file previews are needed."
|
|
:group 'dirvish
|
|
:type '(choice (const :tag "no default layout" nil)
|
|
(list (integer :tag "number of parent windows")
|
|
(float :tag "max width of parent windows")
|
|
(float :tag "width of preview windows"))))
|
|
|
|
(defcustom dirvish-large-directory-threshold nil
|
|
"Directories with file count greater than this are opened using `dirvish-fd'."
|
|
:group 'dirvish :type '(choice (const :tag "Never use `dirvish-fd'" nil)
|
|
(natnum :tag "File counts in integer")))
|
|
|
|
(defface dirvish-hl-line
|
|
'((t :inherit highlight :extend t))
|
|
"Face used for Dirvish line highlighting in focused Dirvish window."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-hl-line-inactive
|
|
'((t :inherit region :extend t))
|
|
"Face used for Dirvish line highlighting in unfocused Dirvish windows."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-inactive
|
|
'((t :inherit shadow))
|
|
"Face used for mode-line segments in unfocused Dirvish windows."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-proc-running
|
|
'((t :inherit warning))
|
|
"Face used if asynchronous process is running."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-proc-finished
|
|
'((t :inherit success))
|
|
"Face used if asynchronous process has finished."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-proc-failed
|
|
'((t :inherit error))
|
|
"Face used if asynchronous process has failed."
|
|
:group 'dirvish)
|
|
|
|
(defcustom dirvish-use-mode-line t
|
|
"Whether to display mode line in dirvish buffers.
|
|
The valid value are:
|
|
- nil: hide mode line in dirvish sessions
|
|
- global: display the mode line across all panes
|
|
- t (and others): Display the mode line across directory panes"
|
|
:group 'dirvish
|
|
:type '(choice (const :tag "Do not show the mode line" nil)
|
|
(const :tag "Display the mode line across directory panes" t)
|
|
(const :tag "Make the mode line span all panes" global)))
|
|
|
|
(defcustom dirvish-use-header-line t
|
|
"Like `dirvish-use-mode-line', but for header line."
|
|
:group 'dirvish :type 'symbol)
|
|
|
|
(defcustom dirvish-mode-line-height 21
|
|
"Height of Dirvish's mode line.
|
|
The value should be a cons cell (H-WIN . H-FRAME), where H-WIN
|
|
and H-FRAME represent the height of mode line in single window
|
|
state and fullframe state respectively. If this value is a
|
|
integer INT, it is seen as a shorthand for (INT . INT)."
|
|
:group 'dirvish
|
|
:type '(choice integer (cons integer integer)))
|
|
|
|
(defcustom dirvish-header-line-height '(25 . 35)
|
|
"Like `dirvish-mode-line-height', but for header line."
|
|
:type '(choice integer (cons integer integer)))
|
|
|
|
(defcustom dirvish-mode-line-format
|
|
'(:left (sort omit symlink) :right (index))
|
|
"Mode line SEGMENTs aligned to left/right respectively.
|
|
Here are all the predefined segments you can choose from:
|
|
|
|
* Basics (from `dirvish-extras')
|
|
`path': directory path under the cursor.
|
|
`symlink': target of symlink under the cursor.
|
|
`sort': sort criteria applied in current buffer.
|
|
`omit': a `dired-omit-mode' indicator.
|
|
`index': line number / total line count.
|
|
`free-space': amount of free space on `default-directory''s file system.
|
|
Others are self-explanatory:
|
|
`file-size', `file-modes', `file-link-number', `file-user',
|
|
`file-group',`file-time',`file-inode-number',`file-device-number'.
|
|
|
|
* Miscs
|
|
`vc-info': version control information (from `dirvish-vc').
|
|
`yank': file transfer progress (from `dirvish-yank').
|
|
|
|
Set it to nil to use the default `mode-line-format'."
|
|
:group 'dirvish :type 'plist)
|
|
|
|
(defcustom dirvish-header-line-format
|
|
'(:left (path) :right ())
|
|
"Like `dirvish-mode-line-format', but for header line ."
|
|
:group 'dirvish :type 'plist)
|
|
|
|
(defcustom dirvish-mode-line-bar-image-width 3
|
|
"Pixel width of the leading bar image in both mode-line and header-line.
|
|
If the value is 0, the bar image is hidden."
|
|
:group 'dirvish :type 'integer)
|
|
|
|
(defcustom dirvish-hide-details t
|
|
"Whether to enable `dired-hide-details-mode' in Dirvish buffers.
|
|
When sets to t, it is enabled for all Dirvish buffers.
|
|
|
|
Alternatively, the value can be a list of symbols to instruct Dirvish in
|
|
what contexts it should be enabled. The accepted values are:
|
|
- `dired': when opening a directory using `dired-*' commands.
|
|
- `dirvish': when opening full-frame Dirvish.
|
|
- `dirvish-fd': when the buffer is create by `dirvish-fd*' commands.
|
|
- `dirvish-side': when opening Dirvish in the sidebar."
|
|
:group 'dirvish
|
|
:type '(choice (boolean :tag "Apply to all Dirvish buffers")
|
|
(repeat :tag "Apply to a list of buffer types: 'dired, 'dirvish, 'dirvish-fd or 'dirvish-side" symbol)))
|
|
|
|
(defcustom dirvish-hide-cursor t
|
|
"Whether to hide cursor in dirvish buffers.
|
|
Works all the same as `dirvish-hide-details' but for cursor."
|
|
:group 'dirvish
|
|
:type '(choice (boolean :tag "Apply to all Dirvish buffers")
|
|
(repeat :tag "Apply to a list of buffer types: 'dired, 'dirvish, 'dirvish-fd or 'dirvish-side" symbol)))
|
|
|
|
(defcustom dirvish-window-fringe 2
|
|
"Root window's left fringe in pixels."
|
|
:group 'dirvish :type 'natnum)
|
|
|
|
(defcustom dirvish-preview-dired-sync-omit nil
|
|
"If non-nil, `dired' preview buffers sync `dired-omit-mode' from root window.
|
|
Notice that it only take effects on the built-in `dired' preview dispatcher."
|
|
:group 'dirvish :type 'boolean)
|
|
|
|
(defcustom dirvish-preview-large-file-threshold 1048576 ; 1mb
|
|
"Text files larger than this byte limit are previewed partially."
|
|
:group 'dirvish :type '(natnum :tag "File size in bytes"))
|
|
|
|
(defcustom dirvish-preview-buffers-max-count 5
|
|
"Number of file buffers to keep open temporarily during preview."
|
|
:group 'dirvish :type '(natnum :tag "Number of buffers"))
|
|
|
|
(defcustom dirvish-reuse-session 'open
|
|
"Whether to keep the latest session index buffer for later reuse.
|
|
The valid values are:
|
|
- t: keep index buffer on both `dirvish-quit' and file open
|
|
- `resume': keep and resume to the index when using `dirvish' w/o specify a path
|
|
- `quit': only keep index after `dirvish-quit'
|
|
- `open': only keep index after open a file
|
|
- nil: never keep any index buffers on `dirvish-quit' or open files"
|
|
:group 'dirvish :type '(choice (const :tag "keep index buffer on both `dirvish-quit' and file open" t)
|
|
(const :tag "keep and resume to the index when using `dirvish' w/o specify a path" resume)
|
|
(const :tag "only keep index after `dirvish-quit'" quit)
|
|
(const :tag "only keep index after open a file" open)
|
|
(const :tag "never keep any index buffer" nil)))
|
|
|
|
(defcustom dirvish-input-throttle 0.25
|
|
"Input THROTTLE for commands run repeatedly within a short period of time.
|
|
The preview window and any associated asynchronous processes for the
|
|
file under the cursor are updated and started only every THROTTLE
|
|
seconds. This also applies root window's refreshing for synchronous
|
|
filtering commands like ``dirvish-narrow'`."
|
|
:group 'dirvish :type '(float :tag "Delay in seconds"))
|
|
|
|
(define-obsolete-variable-alias 'dirvish-redisplay-debounce 'dirvish-input-debounce "Mar 25, 2025")
|
|
(defcustom dirvish-input-debounce 0.02
|
|
"Input DEBOUNCE for commands run repeatedly within a short period of time.
|
|
The preview window and any associated asynchronous processes for the
|
|
file under the cursor are updated and started only when there has not
|
|
been new input for DEBOUNCE seconds. This also applies to root window's
|
|
refreshing for synchronous filtering commands like `dirvish-narrow'."
|
|
:group 'dirvish :type '(float :tag "Delay in seconds"))
|
|
|
|
(cl-defgeneric dirvish-clean-cache () "Clean cache for selected files." nil)
|
|
(cl-defgeneric dirvish-build-cache () "Build cache for current directory." nil)
|
|
|
|
(defcustom dirvish-after-revert-hook '(dirvish-clean-cache)
|
|
"Functions called after running `revert-buffer' command."
|
|
:group 'dirvish :type 'hook)
|
|
|
|
(defcustom dirvish-setup-hook '(dirvish-build-cache)
|
|
"Functions called when directory data for the root buffer is ready."
|
|
:group 'dirvish :type 'hook)
|
|
|
|
(defcustom dirvish-find-entry-hook nil
|
|
"Functions to be called before opening a directory or file.
|
|
Each function is called with the file's FILENAME and FIND-FN until one
|
|
returns a non-nil value. When a Dired buffer is created for the first
|
|
time, FIND-FN is `dired', and the function is called with that Dired
|
|
buffer as `current-buffer'; Otherwise, it is one of `find-file',
|
|
`find-alternate-file', or `find-file-other-window'. A non-nil return
|
|
value terminates `dirvish--find-entry', allowing interception of file
|
|
opening and customized handling of specific file types."
|
|
:group 'dirvish :type 'hook)
|
|
|
|
(defcustom dirvish-preview-setup-hook nil
|
|
"Functions called in the file preview buffer."
|
|
:group 'dirvish :type 'hook)
|
|
|
|
;;;; Constants
|
|
|
|
(defconst dirvish-emacs-bin
|
|
(cond
|
|
((and invocation-directory invocation-name)
|
|
(expand-file-name (concat (file-name-as-directory invocation-directory) invocation-name)))
|
|
((eq system-type 'darwin)
|
|
"/Applications/Emacs.app/Contents/MacOS/Emacs")
|
|
(t "emacs")))
|
|
(defconst dirvish-image-exts '("webp" "wmf" "pcx" "xif" "wbmp" "vtf" "tap" "s1j" "sjp" "sjpg" "s1g" "sgi" "sgif" "s1n" "spn" "spng" "xyze" "rgbe" "hdr" "b16" "mdi" "apng" "ico" "pgb" "rlc" "mmr" "fst" "fpx" "fbs" "dxf" "dwg" "djv" "uvvg" "uvg" "uvvi" "uvi" "azv" "psd" "tfx" "t38" "svgz" "svg" "pti" "btf" "btif" "ktx2" "ktx" "jxss" "jxsi" "jxsc" "jxs" "jxrs" "jxra" "jxr" "jxl" "jpf" "jpx" "jpgm" "jpm" "jfif" "jhc" "jph" "jpg2" "jp2" "jls" "hsj2" "hej2" "heifs" "heif" "heics" "heic" "fts" "fit" "fits" "emf" "drle" "cgm" "dib" "bmp" "hif" "avif" "avcs" "avci" "exr" "fax" "icon" "ief" "jpg" "macp" "pbm" "pgm" "pict" "png" "pnm" "ppm" "ras" "rgb" "tga" "tif" "tiff" "xbm" "xpm" "xwd" "jpe" "jpeg" "cr2" "arw"))
|
|
(defconst dirvish-audio-exts '("ape" "stm" "s3m" "ra" "rm" "ram" "wma" "wax" "m3u" "med" "669" "mtm" "m15" "uni" "ult" "mka" "flac" "axa" "kar" "midi" "mid" "s1m" "smp" "smp3" "rip" "multitrack" "ecelp9600" "ecelp7470" "ecelp4800" "vbk" "pya" "lvp" "plj" "dtshd" "dts" "mlp" "eol" "uvva" "uva" "koz" "xhe" "loas" "sofa" "smv" "qcp" "psid" "sid" "spx" "opus" "ogg" "oga" "mp1" "mpga" "m4a" "mxmf" "mhas" "l16" "lbc" "evw" "enw" "evb" "evc" "dls" "omg" "aa3" "at3" "atx" "aal" "acn" "awb" "amr" "ac3" "ass" "aac" "adts" "726" "abs" "aif" "aifc" "aiff" "au" "mp2" "mp3" "mp2a" "mpa" "mpa2" "mpega" "snd" "vox" "wav"))
|
|
(defconst dirvish-video-exts '("f4v" "rmvb" "wvx" "wmx" "wmv" "wm" "asx" "mk3d" "mkv" "fxm" "flv" "axv" "webm" "viv" "yt" "s1q" "smo" "smov" "ssw" "sswf" "s14" "s11" "smpg" "smk" "bk2" "bik" "nim" "pyv" "m4u" "mxu" "fvt" "dvb" "uvvv" "uvv" "uvvs" "uvs" "uvvp" "uvp" "uvvu" "uvu" "uvvm" "uvm" "uvvh" "uvh" "ogv" "m2v" "m1v" "m4v" "mpg4" "mp4" "mjp2" "mj2" "m4s" "3gpp2" "3g2" "3gpp" "3gp" "avi" "mov" "movie" "mpe" "mpeg" "mpegv" "mpg" "mpv" "qt" "vbs"))
|
|
(defconst dirvish-font-exts '("ttf" "ttc" "otf" "woff" "eot"))
|
|
(defconst dirvish-archive-exts '("7z" "xz" "bzip2" "gzip" "tar" "zip" "wim" "ar" "arj" "cab" "chm" "dmg" "ext" "fat" "gpt" "hfs" "ihex" "iso" "mbr" "msi" "ntfs" "qcow2" "rar" "rpm" "udf" "uefi" "vdi" "vhd" "vmdk" "xar"))
|
|
(defconst dirvish-binary-exts (append dirvish-image-exts dirvish-video-exts dirvish-audio-exts dirvish-font-exts dirvish-archive-exts '("pdf" "epub" "gif" "icns")))
|
|
|
|
;;;; Keymaps
|
|
|
|
(defvar dirvish-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(set-keymap-parent map dired-mode-map)
|
|
(define-key map (kbd "q") 'dirvish-quit) map)
|
|
"Keymap used in dirvish buffers, it inherits `dired-mode-map'.")
|
|
(defvar dirvish-directory-view-mode-map
|
|
(let ((km (make-sparse-keymap))) (define-key km (kbd "q") 'dirvish-quit) km))
|
|
(defvar dirvish-misc-mode-map
|
|
(let ((km (make-sparse-keymap))) (define-key km (kbd "q") 'dirvish-quit) km))
|
|
(defvar dirvish-special-preview-mode-map
|
|
(let ((km (make-sparse-keymap))) (define-key km (kbd "q") 'dirvish-quit) km))
|
|
|
|
;;;; Internal variables
|
|
|
|
(defvar dirvish--scopes
|
|
'(:frame selected-frame :tab tab-bar--current-tab-index :persp persp-curr))
|
|
(defvar dirvish--libraries
|
|
'((dirvish-vc vc-state git-msg vc-diff vc-blame vc-log vc-info)
|
|
(dirvish-icons all-the-icons nerd-icons vscode-icon)
|
|
(dirvish-collapse collapse)
|
|
(dirvish-subtree subtree-state)
|
|
(dirvish-yank yank)))
|
|
(defvar dirvish--timers `(:default (,(timer-create) ,(float-time) nil)))
|
|
(defvar dirvish--selected-window nil)
|
|
(defvar dirvish--sessions (make-hash-table :test #'equal))
|
|
(defvar dirvish--available-attrs '())
|
|
(defvar dirvish--available-preview-dispatchers '())
|
|
(defvar-local dirvish--props '())
|
|
(defvar-local dirvish--dir-data nil)
|
|
|
|
;;;; Helpers
|
|
|
|
(defmacro dirvish-prop (prop &rest body)
|
|
"Retrieve PROP from `dirvish--props'.
|
|
Set the PROP with BODY if given."
|
|
(declare (indent defun))
|
|
`(let* ((pair (assq ,prop dirvish--props)) (val (cdr pair)))
|
|
,(if body `(prog1 (setq val ,@body)
|
|
(if pair (setcdr (assq ,prop dirvish--props) val)
|
|
(push (cons ,prop val) dirvish--props)))
|
|
`val)))
|
|
|
|
(defun dirvish--run-with-delay (action &optional record fun debounce throttle)
|
|
"Run function FUN accroding to ACTION with delay.
|
|
DEBOUNCE defaults to `dirvish-input-debounce'.
|
|
THROTTLE defaults to `dirvish-input-throttle'.
|
|
RECORD defaults to `:default' record in `dirvish--timers'."
|
|
(declare (indent defun))
|
|
(unless (plist-get dirvish--timers (setq record (or record :default)))
|
|
(cl-callf append dirvish--timers
|
|
`(,record (,(timer-create) ,(float-time) nil))))
|
|
(setq record (plist-get dirvish--timers record) fun (or fun #'ignore)
|
|
debounce (or debounce dirvish-input-debounce)
|
|
throttle (or throttle dirvish-input-throttle))
|
|
(pcase action
|
|
((pred stringp)
|
|
(unless (equal action (nth 2 record))
|
|
(cancel-timer (car record))
|
|
(timer-set-function
|
|
(car record)
|
|
(lambda () (setf (nth 1 record) (float-time)) (funcall fun action)))
|
|
(timer-set-time
|
|
(car record)
|
|
(timer-relative-time
|
|
nil (max debounce (- (+ (nth 1 record) throttle) (float-time)))))
|
|
(setf (nth 2 record) action)
|
|
(timer-activate (car record))))
|
|
('reset (setf (nth 2 record) ""))))
|
|
|
|
(defmacro dirvish-save-dedication (&rest body)
|
|
"Run BODY after undedicating window, restore dedication afterwards."
|
|
(declare (debug (&rest form)))
|
|
`(let* ((w (selected-window)) (ded (window-dedicated-p w)))
|
|
(set-window-dedicated-p w nil)
|
|
(prog1 ,@body (and (window-live-p w) (set-window-dedicated-p w ded)))))
|
|
|
|
(defsubst dirvish-curr ()
|
|
"Return Dirvish session attached to current buffer, if there is any."
|
|
(gethash (dirvish-prop :dv) dirvish--sessions))
|
|
|
|
(defun dirvish--ht ()
|
|
"Return a new hash-table with `equal' as its test function."
|
|
(make-hash-table :test #'equal))
|
|
|
|
(defun dirvish--timestamp ()
|
|
"Return current timestamp string with \"%D|%T\" format."
|
|
(format-time-string "%D|%T"))
|
|
|
|
(defun dirvish--display-buffer (buffer alist)
|
|
"Try displaying BUFFER with ALIST.
|
|
This splits the window at the designated side of the frame.
|
|
ALIST is window arguments passed to `window--display-buffer'."
|
|
(let* ((side (cdr (assq 'side alist)))
|
|
(window-configuration-change-hook nil)
|
|
(width (or (cdr (assq 'window-width alist)) 0.5))
|
|
(height (cdr (assq 'window-height alist)))
|
|
(size (or height (ceiling (* (frame-width) width))))
|
|
(split-width-threshold 0)
|
|
(ignore-window-parameters t)
|
|
(new-window (split-window-no-error nil size side)))
|
|
(window--display-buffer buffer new-window 'window alist)))
|
|
|
|
(defun dirvish--kill-buffer (buffer)
|
|
"Kill BUFFER without side effects."
|
|
(and (buffer-live-p buffer)
|
|
(cl-letf (((symbol-function 'undo-tree-save-history-from-hook) #'ignore)
|
|
((symbol-function 'recentf-track-closed-file) #'ignore))
|
|
(let (kill-buffer-query-functions) (kill-buffer buffer)))))
|
|
|
|
(defun dirvish--vc-root-dir ()
|
|
"Get expanded `vc-root-dir'."
|
|
(when-let* ((root (vc-root-dir))) (expand-file-name root)))
|
|
|
|
(defun dirvish--get-parent-path (path)
|
|
"Get parent directory of PATH."
|
|
(file-name-directory (directory-file-name (expand-file-name path))))
|
|
|
|
(defun dirvish--completion-table-with-metadata (table metadata)
|
|
"Return new completion TABLE with METADATA, see `completion-metadata'."
|
|
(lambda (string pred action)
|
|
(if (eq action 'metadata)
|
|
`(metadata . ,metadata)
|
|
(complete-with-action action table string pred))))
|
|
|
|
(defun dirvish--format-menu-heading (title &optional note)
|
|
"Format TITLE as a menu heading.
|
|
When NOTE is non-nil, append it the next line."
|
|
(let ((no-wb (= (frame-bottom-divider-width) 0)))
|
|
(format "%s%s%s"
|
|
(propertize title 'face `(:inherit dired-mark :overline ,no-wb)
|
|
'display '((height 1.1)))
|
|
(propertize " " 'face `(:inherit dired-mark :overline ,no-wb)
|
|
'display '(space :align-to right))
|
|
(propertize (if note (concat "\n" note) "") 'face 'font-lock-doc-face))))
|
|
|
|
(defun dirvish--special-buffer (type dv &optional no-hiding)
|
|
"Return DV's special TYPE buffer, do not hide it if NO-HIDING is non-nil."
|
|
(get-buffer-create
|
|
(format "%s*dirvish-%s@%s*" (if no-hiding "" " ") type (dv-id dv))))
|
|
|
|
(defun dirvish--make-proc (form sentinel buffer-or-name &rest puts)
|
|
"Make process for shell or batch FORM in BUFFER-OR-NAME.
|
|
Set process's SENTINEL and PUTS accordingly."
|
|
(let* ((buf (or buffer-or-name (make-temp-name "*dirvish-batch*")))
|
|
(print-length nil) (print-level nil)
|
|
(cmd (if (stringp (car form)) form
|
|
(list dirvish-emacs-bin
|
|
"-Q" "-batch" "--eval" (prin1-to-string form))))
|
|
(proc (make-process :name "dirvish" :connection-type nil :buffer buf
|
|
:command cmd :sentinel sentinel :noquery t)))
|
|
(while-let ((k (pop puts)) (v (pop puts))) (process-put proc k v))))
|
|
|
|
;;;; Session Struct
|
|
|
|
(cl-defstruct (dirvish (:conc-name dv-))
|
|
"Define dirvish session (DV for short) struct."
|
|
(id (make-temp-name "") :documentation "is the unique key of DV stored in `dirvish--sessions'.")
|
|
(timestamp (dirvish--timestamp) :documentation "is the last access timestamp of DV.")
|
|
(type 'default :documentation "is the type of DV.")
|
|
(root-window () :documentation "is the root/main window of DV.")
|
|
(dedicated () :documentation "passes to `set-window-dedicated-p' for ROOT-WINDOW.")
|
|
(size-fixed () :documentation "passes to `window-size-fixed' for ROOT-WINDOW.")
|
|
(root-conf #'ignore :documentation "is a function to apply extra configs for INDEX buffer.")
|
|
(root-window-fn () :documentation "is a function used to create the ROOT-WINDOW for DV.")
|
|
(open-file #'dirvish-open-file :documentation "is a function to handle file opening.")
|
|
(curr-layout () :documentation "is the working layout recipe of DV.")
|
|
(ff-layout dirvish-default-layout :documentation "is a full-frame layout recipe.")
|
|
(ls-switches dired-listing-switches :documentation "is the directory listing switches.")
|
|
(mode-line () :documentation "is the `mode-line-format' used by DV.")
|
|
(header-line () :documentation "is the `header-line-format' used by DV.")
|
|
(preview-dispatchers () :documentation "is the working preview methods of DV.")
|
|
(preview-hash (dirvish--ht) :documentation "is a hash-table to record content of preview files.")
|
|
(parent-hash (dirvish--ht) :documentation "is a hash-table to record content of parent directories.")
|
|
(attributes () :documentation "is the working attributes of DV.")
|
|
(preview-buffers () :documentation "holds all file preview buffers of DV.")
|
|
(special-buffers () :documentation "holds all special buffers of DV e.g. mode-line buffer.")
|
|
(preview-window () :documentation "is the window to display preview buffer.")
|
|
(winconf () :documentation "is a saved window configuration.")
|
|
(index () :documentation "is the (cwd-str . buf-obj) cons within ROOT-WINDOW.")
|
|
(roots () :documentation "is all the history INDEX entries in DV."))
|
|
|
|
(defun dirvish--new (&rest args)
|
|
"Create and save a new dirvish struct to `dirvish--sessions'.
|
|
ARGS is a list of keyword arguments for `dirvish' struct."
|
|
(let (slots new)
|
|
(while (keywordp (car args)) (dotimes (_ 2) (push (pop args) slots)))
|
|
(setq new (apply #'make-dirvish (reverse slots)))
|
|
;; ensure we have a fallback fullframe layout
|
|
(unless dirvish-default-layout (setf (dv-ff-layout new) '(1 0.11 0.55)))
|
|
(puthash (dv-id new) new dirvish--sessions)
|
|
(dirvish--check-dependencies new)
|
|
(dirvish--create-root-window new) new))
|
|
|
|
(defun dirvish--selected-p (&optional dv)
|
|
"Return t if session DV (defaults to `dirvish-curr') is selected."
|
|
(when-let* ((dv (or dv (dirvish-curr))))
|
|
(if (dv-curr-layout dv) (eq (dv-root-window dv) dirvish--selected-window)
|
|
(eq (frame-selected-window) dirvish--selected-window))))
|
|
|
|
(defun dirvish--get-session (&optional key val)
|
|
"Return the first matched session has KEY of VAL."
|
|
(setq key (or key 'type) val (or val 'default))
|
|
(cl-loop for dv being the hash-values of dirvish--sessions
|
|
for b = (cdr (dv-index dv))
|
|
with (fr tab psp) = (cl-loop for (_ v) on dirvish--scopes by 'cddr
|
|
collect (and (functionp v) (funcall v)))
|
|
if (or (null b) ; newly created session
|
|
(and (buffer-live-p b)
|
|
(eq (with-current-buffer b (dirvish-prop :tab)) tab)
|
|
(eq (with-current-buffer b (dirvish-prop :frame)) fr)
|
|
(eq (with-current-buffer b (dirvish-prop :persp)) psp)))
|
|
if (let ((res (funcall (intern (format "dv-%s" key)) dv)))
|
|
(cond ((eq val 'any) res)
|
|
((eq key 'roots) (memq val (mapcar #'cdr res)))
|
|
(t (equal val res))))
|
|
return dv))
|
|
|
|
(defun dirvish--clear-session (dv &optional from-quit)
|
|
"Reset DV's slot and kill its buffers.
|
|
FROM-QUIT is used to signify the calling command."
|
|
(let* ((idx (dv-index dv)) (ff (dv-curr-layout dv)) (wcon (dv-winconf dv))
|
|
(server-buf? (lambda (root) (with-current-buffer (cdr root)
|
|
(bound-and-true-p server-buffer-clients))))
|
|
(keep (list idx)) roots kill-buffer-hook)
|
|
(cl-loop with killer = (lambda (r) (unless (member r keep) (kill-buffer (cdr r))))
|
|
for root in (setq roots (dv-roots dv))
|
|
if (or (get-buffer-window (cdr root)) (funcall server-buf? root))
|
|
do (cl-pushnew root keep :test #'equal)
|
|
finally do (mapc killer roots))
|
|
(when (and ff wcon) (set-window-configuration wcon))
|
|
(set-window-fringes
|
|
nil (frame-parameter nil 'left-fringe) (frame-parameter nil 'left-fringe))
|
|
(mapc #'dirvish--kill-buffer (dv-preview-buffers dv))
|
|
(mapc #'dirvish--kill-buffer (dv-special-buffers dv))
|
|
(when (or (null dirvish-reuse-session)
|
|
(eq dirvish-reuse-session (if from-quit 'open 'quit)))
|
|
(unless (or (funcall server-buf? idx) ; client buf or displayed elsewhere
|
|
(length> (get-buffer-window-list (cdr idx)) 1))
|
|
(kill-buffer (cdr idx))))
|
|
(setq roots (cl-remove-if-not (lambda (i) (buffer-live-p (cdr i))) keep))
|
|
(setf (dv-preview-hash dv) (dirvish--ht) (dv-parent-hash dv) (dirvish--ht)
|
|
(dv-roots dv) roots (dv-index dv) (car roots)
|
|
(dv-preview-buffers dv) nil (dv-winconf dv) nil)
|
|
(unless roots (remhash (dv-id dv) dirvish--sessions))))
|
|
|
|
(defun dirvish--create-root-window (dv)
|
|
"Create root window of DV."
|
|
(if-let* ((fn (dv-root-window-fn dv)))
|
|
(setf (dv-root-window dv) (funcall fn dv))
|
|
(setf (dv-root-window dv) (frame-selected-window))))
|
|
|
|
(defun dirvish--preview-dps-validate (&optional dps)
|
|
"Check if the requirements of dispatchers DPS are met."
|
|
(cl-loop with dps = (or dps dirvish-preview-dispatchers)
|
|
with res = (prog1 '() (require 'recentf) (require 'ansi-color))
|
|
with fmt = "[Dirvish]: install '%s' executable to preview %s files."
|
|
for dp in (append '(disable) dps '(dired fallback))
|
|
for info = (alist-get dp dirvish--available-preview-dispatchers)
|
|
for requirements = (plist-get info :require)
|
|
for met = t
|
|
do (progn (dolist (pkg requirements)
|
|
(unless (executable-find pkg)
|
|
(message fmt pkg dp) (setq met nil)))
|
|
(when met (push (intern (format "dirvish-%s-dp" dp)) res)))
|
|
finally return (reverse res)))
|
|
|
|
(defun dirvish--check-dependencies (dv)
|
|
"Require necessary extensions for DV, raise warnings for missing executables."
|
|
(cl-loop
|
|
with tp = (dv-type dv) with dft = (eq tp 'default)
|
|
with fn = (lambda (f) (eval `(bound-and-true-p
|
|
,(intern (format "dirvish-%s-%s" tp f)))))
|
|
with attrs = (if dft dirvish-attributes (funcall fn 'attributes))
|
|
with m = (if dft dirvish-mode-line-format (funcall fn 'mode-line-format))
|
|
with h = (if dft dirvish-header-line-format (funcall fn 'header-line-format))
|
|
with (ml . mr) = (cons (plist-get m :left) (plist-get m :right))
|
|
with (hl . hr) = (cons (plist-get h :left) (plist-get h :right))
|
|
with feat-reqs = (append dirvish-preview-dispatchers attrs ml mr hl hr)
|
|
when feat-reqs do (require 'dirvish-widgets)
|
|
for (lib . feat) in dirvish--libraries do
|
|
(when (cl-intersection feat feat-reqs) (require lib))
|
|
finally (setf (dv-mode-line dv) (dirvish--mode-line-composer ml mr)
|
|
(dv-header-line dv) (dirvish--mode-line-composer hl hr t)
|
|
(dv-preview-dispatchers dv) (dirvish--preview-dps-validate)
|
|
(dv-attributes dv) (dirvish--attrs-expand attrs))))
|
|
|
|
(defun dirvish-open-file (dv find-fn file)
|
|
"Open FILE using FIND-FN for default DV sessions."
|
|
(let ((cur (current-buffer)) fbuf)
|
|
(unwind-protect (funcall find-fn file)
|
|
(unless (eq (setq fbuf (current-buffer)) cur)
|
|
(dirvish--clear-session dv)
|
|
(dirvish-save-dedication (switch-to-buffer fbuf))))))
|
|
|
|
(cl-defun dirvish--find-entry (find-fn entry)
|
|
"Find ENTRY using FIND-FN in current dirvish session.
|
|
FIND-FN can be one of `find-file', `find-alternate-file',
|
|
`find-file-other-window' or `find-file-other-frame'."
|
|
(let ((switch-to-buffer-preserve-window-point (null dired-auto-revert-buffer))
|
|
(find-file-run-dired t) (dv (dirvish-curr))
|
|
(dir? (file-directory-p entry)) (cur (current-buffer)))
|
|
(and (run-hook-with-args-until-success
|
|
'dirvish-find-entry-hook entry find-fn)
|
|
(cl-return-from dirvish--find-entry))
|
|
;; forward requests from `find-dired'
|
|
(unless dv (cl-return-from dirvish--find-entry (funcall find-fn entry)))
|
|
(unless dir? (mapc #'dirvish--kill-buffer (dv-preview-buffers dv)))
|
|
(when (and (dv-curr-layout dv) (eq find-fn 'find-file-other-window))
|
|
(if dir? (dirvish-layout-toggle)
|
|
(select-window (dv-preview-window dv))
|
|
(cl-return-from dirvish--find-entry (find-file entry))))
|
|
(when (and dir? (eq find-fn 'find-alternate-file))
|
|
(dirvish-save-dedication (find-file entry))
|
|
(with-current-buffer cur ; check if the buffer should be killed
|
|
(and (bound-and-true-p server-buffer-clients)
|
|
(cl-return-from dirvish--find-entry)))
|
|
(cl-return-from dirvish--find-entry (dirvish--kill-buffer cur)))
|
|
(if dir? (dirvish-save-dedication (funcall find-fn entry))
|
|
(funcall (dv-open-file dv) dv find-fn entry))))
|
|
|
|
;;;; Preview
|
|
|
|
(cl-defmacro dirvish-define-preview (name &optional arglist docstring &rest body)
|
|
"Define a Dirvish preview dispatcher NAME.
|
|
A dirvish preview dispatcher is a function consumed by
|
|
`dirvish-preview-dispatch' which takes `file' (filename under
|
|
the cursor) and `preview-window' as ARGLIST. DOCSTRING and BODY
|
|
is the docstring and body for this function."
|
|
(declare (indent defun) (doc-string 3))
|
|
(let* ((dp-name (intern (format "dirvish-%s-dp" name)))
|
|
(default-arglist '(file ext preview-window dv))
|
|
(ignore-list (cl-set-difference default-arglist arglist))
|
|
(keywords `(:doc ,docstring)))
|
|
(while (keywordp (car body)) (dotimes (_ 2) (push (pop body) keywords)))
|
|
`(progn
|
|
(add-to-list
|
|
'dirvish--available-preview-dispatchers (cons ',name ',keywords))
|
|
(defun ,dp-name ,default-arglist (ignore ,@ignore-list) ,@body))))
|
|
|
|
(defun dirvish--preview-file-maybe-truncate (dv file size)
|
|
"Return preview buffer of FILE with SIZE in DV."
|
|
(when (>= (length (dv-preview-buffers dv)) dirvish-preview-buffers-max-count)
|
|
(dirvish--kill-buffer (frame-parameter nil 'dv-preview-last)))
|
|
(with-current-buffer (get-buffer-create "*preview-temp*")
|
|
(let ((text (gethash file (dv-preview-hash dv))) info jka-compr-verbose)
|
|
(with-silent-modifications
|
|
(setq buffer-read-only t)
|
|
(if text (insert text)
|
|
(insert-file-contents
|
|
file nil 0 dirvish-preview-large-file-threshold)
|
|
(when (>= size dirvish-preview-large-file-threshold)
|
|
(goto-char (point-max))
|
|
(insert "\n\nFile truncated. End of partial preview.\n")))
|
|
(setq buffer-file-name file)
|
|
(goto-char (point-min))
|
|
(rename-buffer (format "PREVIEW :: %s :: %s"
|
|
(dv-timestamp dv) (file-name-nondirectory file))))
|
|
(condition-case err
|
|
(eval `(let ,(mapcar (lambda (env) `(,(car env) ,(cdr env)))
|
|
(remove '(delay-mode-hooks . t)
|
|
dirvish-preview-environment))
|
|
(setq-local delay-mode-hooks t)
|
|
(set-auto-mode) (font-lock-mode 1)
|
|
(and (bound-and-true-p so-long-detected-p)
|
|
(error "No preview of file with long lines"))))
|
|
(error (setq info (error-message-string err))))
|
|
(if info (prog1 `(info . ,info) (dirvish--kill-buffer (current-buffer)))
|
|
(set-frame-parameter nil 'dv-preview-last (current-buffer))
|
|
(run-hooks 'dirvish-preview-setup-hook)
|
|
(unless text (puthash file (buffer-string) (dv-preview-hash dv)))
|
|
`(buffer . ,(current-buffer))))))
|
|
|
|
(defun dirvish--find-file-temporarily (name)
|
|
"Open file NAME temporarily for preview."
|
|
`(buffer . ,(eval `(let ,(mapcar (lambda (env) `(,(car env) ,(cdr env)))
|
|
(append '((vc-follow-symlinks . t)
|
|
(find-file-hook . nil))
|
|
dirvish-preview-environment))
|
|
(find-file-noselect ,name 'nowarn)))))
|
|
|
|
(dirvish-define-preview disable (file ext)
|
|
"Disable preview in some cases."
|
|
(cond
|
|
((not (file-exists-p file))
|
|
`(info . ,(format "[ %s ] does not exist" file)))
|
|
((not (file-readable-p file))
|
|
`(info . ,(format "[ %s ] is not readable" file)))
|
|
((member ext dirvish-preview-disabled-exts)
|
|
`(info . ,(format "Preview for filetype [ %s ] has been disabled" ext)))))
|
|
|
|
(dirvish-define-preview dired (file)
|
|
"Preview dispatcher for directory FILE."
|
|
(when (file-directory-p file)
|
|
`(dired . (let ,(mapcar (lambda (env) `(,(car env) ,(cdr env)))
|
|
(remove (cons 'inhibit-message t)
|
|
dirvish-preview-environment))
|
|
(setq insert-directory-program ,insert-directory-program)
|
|
(setq dired-listing-switches ,dired-listing-switches)
|
|
(setq dired-omit-verbose ,(bound-and-true-p dired-omit-verbose))
|
|
(setq dired-omit-files ,(bound-and-true-p dired-omit-files))
|
|
;; for `sudo-edit' compat
|
|
(with-current-buffer (dired-noselect ,file)
|
|
,(and dirvish-preview-dired-sync-omit
|
|
(bound-and-true-p dired-omit-mode)
|
|
`(dired-omit-mode))
|
|
(message "\n%s" (buffer-string)))))))
|
|
|
|
(dirvish-define-preview fallback (file ext dv)
|
|
"Fallback preview dispatcher for FILE."
|
|
(let* ((attrs (ignore-errors (file-attributes file)))
|
|
(size (file-attribute-size attrs)) buf)
|
|
(cond ((setq buf (get-buffer
|
|
(format "PREVIEW :: %s :: %s"
|
|
(dv-timestamp dv) (file-name-nondirectory file))))
|
|
`(buffer . ,buf))
|
|
((not attrs)
|
|
`(info . ,(format "Can not get attributes of [ %s ]." file)))
|
|
((not size)
|
|
`(info . ,(format "Can not get file size of [ %s ]." file)))
|
|
((> size (or large-file-warning-threshold 10000000))
|
|
`(info . ,(format "File [ %s ] is too big for literal preview." file)))
|
|
((member ext dirvish-binary-exts)
|
|
`(info . "Preview disabled for binary files"))
|
|
(t (dirvish--preview-file-maybe-truncate dv file size)))))
|
|
|
|
(cl-defgeneric dirvish-preview-dispatch (recipe dv)
|
|
"Return preview buffer generated according to RECIPE in session DV.")
|
|
|
|
(cl-defmethod dirvish-preview-dispatch ((recipe (head info)) dv)
|
|
"Insert info string from RECIPE into DV's preview buffer."
|
|
(let ((buf (dirvish--special-buffer 'preview dv t)))
|
|
(with-current-buffer buf
|
|
(let (buffer-read-only)
|
|
(erase-buffer) (remove-overlays) (insert "\n\n " (cdr recipe)) buf))))
|
|
|
|
(cl-defmethod dirvish-preview-dispatch ((recipe (head buffer)) dv)
|
|
"Use payload of RECIPE as preview buffer of DV directly."
|
|
(let ((p-buf (dirvish--special-buffer 'preview dv t)))
|
|
(with-current-buffer p-buf
|
|
(let (buffer-read-only) (erase-buffer) (remove-overlays) (cdr recipe)))))
|
|
|
|
(defun dirvish-apply-ansicolor-h (_win pos)
|
|
"Update dirvish ansicolor in preview window from POS."
|
|
(declare-function ansi-color-apply-on-region "ansi-color")
|
|
(let (buffer-read-only)
|
|
(ansi-color-apply-on-region
|
|
(goto-char pos) (progn (forward-line (frame-height)) (point)))))
|
|
|
|
(defun dirvish-shell-preview-proc-s (proc _exitcode)
|
|
"A sentinel for dirvish preview process.
|
|
When PROC finishes, fill preview buffer with process result."
|
|
(when-let* ((dv (dirvish-curr)) (cmd-type (process-get proc 'cmd-info))
|
|
(str (with-current-buffer (process-buffer proc) (buffer-string))))
|
|
(if (eq cmd-type 'shell)
|
|
(with-current-buffer (dirvish--special-buffer 'shell dv t)
|
|
(let (buffer-read-only) (erase-buffer) (remove-overlays) (insert str))
|
|
(dirvish-apply-ansicolor-h nil (point-min)))
|
|
(with-current-buffer (dirvish--special-buffer 'dired dv t)
|
|
(let (buffer-read-only) (erase-buffer) (remove-overlays) (insert str))
|
|
(setq-local dired-subdir-alist
|
|
(list (cons (car (dv-index dv)) (point-min-marker))))))
|
|
(kill-buffer (process-buffer proc))))
|
|
|
|
(defun dirvish--run-shell-for-preview (dv recipe)
|
|
"Dispatch shell cmd with RECIPE for session DV."
|
|
(let ((proc (get-buffer-process (get-buffer " *dirvish-sh*")))
|
|
(buf (dirvish--special-buffer (car recipe) dv t)))
|
|
(when proc (delete-process proc))
|
|
(dirvish--make-proc
|
|
(cdr recipe) 'dirvish-shell-preview-proc-s " *dirvish-sh*"
|
|
'cmd-info (car recipe))
|
|
(with-current-buffer buf
|
|
(let (buffer-read-only) (erase-buffer) buf))))
|
|
|
|
(cl-defmethod dirvish-preview-dispatch ((recipe (head shell)) dv)
|
|
"Fill DV's preview buffer with output of sh command from RECIPE."
|
|
(dirvish--run-shell-for-preview dv recipe))
|
|
|
|
(cl-defmethod dirvish-preview-dispatch ((recipe (head dired)) dv)
|
|
"Fill DV's preview buffer with output of sh command from RECIPE."
|
|
(dirvish--run-shell-for-preview dv recipe))
|
|
|
|
(defun dirvish--preview-update (dv index)
|
|
"Update preview content of INDEX for DV."
|
|
(when-let* ((pwin (dv-preview-window dv)) ((window-live-p pwin))
|
|
(root (cdr (dv-index dv))) ((buffer-live-p root))
|
|
(ext (downcase (or (file-name-extension index) "")))
|
|
(fns (with-current-buffer root (dirvish-prop :preview-dps)))
|
|
(buf (cl-loop for fn in fns
|
|
for rcp = (funcall fn index ext pwin dv) thereis
|
|
(and rcp (dirvish-preview-dispatch rcp dv)))))
|
|
(setq-local other-window-scroll-buffer buf)
|
|
(unless (memq buf (dv-special-buffers dv))
|
|
(cl-pushnew buf (dv-preview-buffers dv)))
|
|
(set-window-buffer pwin buf)))
|
|
|
|
;;;; Attributes
|
|
|
|
(defmacro dirvish-define-attribute (name docstring &rest body)
|
|
"Define a Dirvish attribute NAME with DOCSTRING.
|
|
An Dirvish attribute contains:
|
|
- a PREDICATE form, which is the value of `:when' keyword
|
|
- a SETUP form, which is the value of `:setup' keyword
|
|
- a RENDER function runs BODY (excludes all the keywords)
|
|
|
|
During redisplay, the PREDICATE is evaluated with WIN-WIDTH (from
|
|
`window-width') bound locally, a nil result means the attribute should
|
|
not be rendered. Otherwise, SETUP form is evalutated once and RENDER is
|
|
called for every file line in the viewport with the following arguments:
|
|
|
|
- `f-beg' from `dired-move-to-filename'
|
|
- `f-end' from `dired-move-to-end-of-filename'
|
|
- `f-str' from (`buffer-substring' F-BEG F-END)
|
|
- `f-name' from `dired-get-filename'
|
|
- `f-attrs' from `file-attributes'
|
|
- `f-type' from `file-directory-p' along with `file-symlink-p'
|
|
- `l-beg' from `line-beginning-position'
|
|
- `l-end' from `line-end-position'
|
|
- `hl-face' from `dirvish-hl-line' face, only passed in for current line
|
|
- `w-width' from `window-width'
|
|
|
|
RENDER should return a cons of (TYPE . VAL) where:
|
|
- TYPE can be one of `ov', `left' or `right'
|
|
- When TYPE is `ov', VAL is a overlay to be put; otherwise VAL is a string
|
|
|
|
The collected `left' strings as a whole is then attached to `f-end',
|
|
while `right' would fill up remaining space within the file line. These
|
|
keywords are used to calculate the starting position of the collected
|
|
`right' strings:
|
|
|
|
- `:width': a form denotes the constant length of the attribute.
|
|
- `:right': like `:width', but only used by `right' TYPE RENDER."
|
|
(declare (indent defun) (doc-string 2))
|
|
(let ((render (intern (format "dirvish-attribute-%s-rd" name)))
|
|
(args '(f-beg f-end f-str f-name f-attrs
|
|
f-type l-beg l-end hl-face w-width))
|
|
options)
|
|
(while (keywordp (car body)) (dotimes (_ 2) (push (pop body) options)))
|
|
(setq options (reverse options))
|
|
`(progn
|
|
(add-to-list
|
|
'dirvish--available-attrs
|
|
(cons ',name '(,(or (plist-get options :width) 0)
|
|
,(or (plist-get options :right) 0)
|
|
,(or (plist-get options :when) t)
|
|
,(or (plist-get options :setup) nil)
|
|
,render ,docstring)))
|
|
(defun ,render ,args (ignore ,@args) ,@body))))
|
|
|
|
(defmacro dirvish-attribute-cache (file attribute &rest body)
|
|
"Get FILE's ATTRIBUTE from `dirvish--dir-data'.
|
|
When the attribute does not exist, set it with BODY."
|
|
(declare (indent defun))
|
|
`(let* ((md5 (secure-hash 'md5 ,file))
|
|
(hash (gethash md5 dirvish--dir-data))
|
|
(cached (plist-get hash ,attribute))
|
|
(attr (or cached ,@body)))
|
|
(unless cached
|
|
(puthash md5 (append hash (list ,attribute attr)) dirvish--dir-data))
|
|
attr))
|
|
|
|
(defun dirvish--attrs-expand (attrs)
|
|
"Expand ATTRS from `dirvish--available-attrs'."
|
|
(cl-pushnew 'hl-line attrs) (cl-pushnew 'symlink-target attrs)
|
|
(sort (cl-loop for attr in attrs
|
|
for lst = (alist-get attr dirvish--available-attrs)
|
|
for (wd wd-r pred setup render _) = lst
|
|
collect (list attr (eval wd) (eval wd-r) pred setup render))
|
|
(lambda (a b) (< (cl-position (car a) attrs) (cl-position (car b) attrs)))))
|
|
|
|
(defun dirvish--render-attrs-1
|
|
(height width pos remote fns align-to hl w-width)
|
|
"HEIGHT WIDTH POS REMOTE FNS ALIGN-TO HL W-WIDTH."
|
|
;; jump over subdir header lines where `forward-line' is ignored
|
|
(when (cdr dired-subdir-alist) (goto-char (window-start)))
|
|
(forward-line (- 0 height))
|
|
(cl-dotimes (_ (* 2 height))
|
|
(when (eobp) (cl-return))
|
|
(let ((f-beg (dired-move-to-filename))
|
|
(f-end (dired-move-to-end-of-filename t))
|
|
(l-beg (line-beginning-position)) (l-end (line-end-position))
|
|
(f-wid 0) f-str f-name f-attrs f-type hl-face left right f-line?)
|
|
(setq hl-face (and (eq (or f-beg l-beg) pos) hl))
|
|
(when (setq f-line? (and f-beg f-end (eq (char-after l-end) 10)))
|
|
(setq f-str (buffer-substring f-beg f-end)
|
|
f-wid (string-width f-str)
|
|
f-name (concat (if remote (dired-current-directory)
|
|
(file-local-name (dired-current-directory)))
|
|
f-str)
|
|
f-attrs (dirvish-attribute-cache f-name :builtin
|
|
(unless remote (ignore-errors (file-attributes f-name))))
|
|
f-type (dirvish-attribute-cache f-name :type
|
|
(let ((ch (progn (back-to-indentation) (char-after))))
|
|
(cond ; ASCII: d -> 100, l -> 108, LF(\n) -> 10
|
|
(remote `(,(if (eq ch 100) 'dir 'file) . nil))
|
|
((eq ch 100) '(dir . nil))
|
|
((eq ch 108) ; use slash for dir check is unreliable
|
|
`(,(if (file-directory-p f-name) 'dir 'file) .
|
|
,(buffer-substring (+ f-end 4) l-end)))
|
|
(t '(file . nil))))))
|
|
(unless (get-text-property f-beg 'mouse-face)
|
|
(dired-insert-set-properties l-beg l-end)))
|
|
(cl-loop
|
|
for fn in (if f-line? fns '(dirvish-attribute-hl-line-rd))
|
|
for (k . v) = (funcall fn f-beg f-end f-str f-name
|
|
f-attrs f-type l-beg l-end hl-face w-width)
|
|
do (pcase k ('ov (overlay-put v 'dirvish-a-ov t))
|
|
('ovs (dolist (ov v) (overlay-put ov 'dirvish-a-ov t)))
|
|
('left (setq left (concat v left)))
|
|
('right (setq right (concat v right))))
|
|
finally
|
|
(prog1 (unless (or left right) (cl-return))
|
|
(let* ((len1 (string-width (or right "")))
|
|
(remain (- width len1
|
|
(or (get-text-property l-beg 'line-prefix) 0)))
|
|
(len2 (min (length left) (max 0 (- remain f-wid 1))))
|
|
(ovl (make-overlay f-end f-end))
|
|
(r-pos (if (> remain f-wid) l-end
|
|
(let ((end (+ f-beg remain))
|
|
(offset (- f-wid (length f-str))))
|
|
(- end offset))))
|
|
(spec `(space :align-to (- right-fringe ,len1 ,align-to)))
|
|
(spc (propertize " " 'display spec 'face hl-face))
|
|
(ovr (make-overlay r-pos r-pos)))
|
|
(overlay-put ovl 'dirvish-l-ov t)
|
|
(overlay-put ovl 'after-string (substring (or left "") 0 len2))
|
|
(overlay-put ovr 'dirvish-r-ov t)
|
|
(overlay-put ovr 'after-string (concat spc right))))))
|
|
(forward-line 1)))
|
|
|
|
(defun dirvish--render-attrs (window &optional selected)
|
|
"Render attributes in WINDOW, SELECTED defaults to `frame-selected-window'."
|
|
(setq selected (or selected (frame-selected-window)))
|
|
(with-selected-window window
|
|
(cl-loop with attrs = (dirvish-prop :attrs) unless attrs do (cl-return)
|
|
with ww = (window-width) and pm = (point-min) and pM = (point-max)
|
|
with rmt = (and (dirvish-prop :remote) (not (dirvish-prop :sudo)))
|
|
with fns = () with height = (frame-height) with gui = nil
|
|
with hl = (and (dirvish--apply-hiding-p dirvish-hide-cursor)
|
|
(if (eq selected window)
|
|
'dirvish-hl-line 'dirvish-hl-line-inactive))
|
|
with remain = (- ww (if (setq gui (dirvish-prop :gui)) 1 2))
|
|
for (_ width _ pred setup render) in attrs
|
|
when (eval pred `((win-width . ,remain)))
|
|
do (eval setup) (setq remain (- remain width)) (push render fns)
|
|
initially (dolist (ov '(dirvish-a-ov dirvish-l-ov dirvish-r-ov))
|
|
(remove-overlays pm pM ov t))
|
|
finally (with-silent-modifications
|
|
(save-excursion
|
|
(dirvish--render-attrs-1
|
|
height remain (point) rmt fns (if gui 0 2) hl ww))))))
|
|
|
|
(dirvish-define-attribute hl-line
|
|
"Highlight current line.
|
|
This attribute is disabled when cursor is visible."
|
|
(when hl-face
|
|
(let ((ov (make-overlay l-beg (1+ l-end))))
|
|
(overlay-put ov 'face hl-face) `(ov . ,ov))))
|
|
|
|
(dirvish-define-attribute symlink-target
|
|
"Hide symlink target."
|
|
:when (or (derived-mode-p 'dirvish-directory-view-mode)
|
|
(and dired-hide-details-mode
|
|
(default-value 'dired-hide-details-hide-symlink-targets)))
|
|
(when (< (+ f-end 4) l-end)
|
|
(let ((ov (make-overlay f-end l-end)))
|
|
(overlay-put ov 'invisible t) `(ov . ,ov))))
|
|
|
|
;;;; Mode Line | Header Line
|
|
|
|
(defmacro dirvish-define-mode-line (name &optional docstring &rest body)
|
|
"Define a mode line segment NAME with BODY and DOCSTRING."
|
|
(declare (indent defun) (doc-string 2))
|
|
(let ((ml-name (intern (format "dirvish-%s-ml" name))))
|
|
`(defun ,ml-name () ,docstring ,@body)))
|
|
|
|
(defun dirvish--mode-line-composer (left right &optional header)
|
|
"Compose `mode-line-format' from LEFT and RIGHT segments.
|
|
If HEADER, the format is used for `header-line-format'."
|
|
`((:eval
|
|
(let* ((dv (dirvish-curr))
|
|
(fullframe-p (and dv (dv-curr-layout dv)))
|
|
(buf (if fullframe-p (cdr (dv-index dv)) (current-buffer)))
|
|
(expand
|
|
(lambda (segs)
|
|
(cl-loop for s in segs collect
|
|
(if (stringp s) s
|
|
`(:eval (,(intern (format "dirvish-%s-ml" s))))))))
|
|
(face ',(if header 'header-line 'mode-line-inactive))
|
|
(default (face-attribute 'default :height))
|
|
(ml-height (face-attribute face :height))
|
|
(scale (cond ((floatp ml-height) ml-height)
|
|
((integerp ml-height) (/ (float ml-height) default))
|
|
(t 1)))
|
|
(win-width (floor (/ (window-width) scale)))
|
|
(str-l (if dv " DIRVISH: context buffer is a killed buffer"
|
|
" DIRVISH: failed to get current session"))
|
|
(str-r (propertize "WARNING " 'face 'dired-warning))
|
|
(len-r 8))
|
|
(when (buffer-live-p buf)
|
|
(setq str-l (format-mode-line (funcall expand ',left) nil nil buf))
|
|
(setq str-r (format-mode-line (funcall expand ',right) nil nil buf))
|
|
(setq len-r (string-width str-r)))
|
|
(concat
|
|
(dirvish--mode-line-bar-img fullframe-p ,header)
|
|
(if (< (+ (string-width str-l) len-r) win-width)
|
|
str-l
|
|
(let ((trim (1- (- win-width len-r))))
|
|
(if (>= trim 0)
|
|
(substring str-l 0 (min trim (1- (length str-l))))
|
|
"")))
|
|
(propertize
|
|
" " 'display `((space :align-to (- (+ right right-fringe right-margin)
|
|
,(ceiling (* scale len-r))))))
|
|
str-r)))))
|
|
|
|
(defun dirvish--mode-line-height (fullframe &optional header)
|
|
"Get mode/header-line (when HEADER) height in single pane or FULLFRAME."
|
|
(let ((hv (if header dirvish-header-line-height dirvish-mode-line-height)))
|
|
(cond ((numberp hv) hv) (fullframe (cdr hv)) (t (car hv)))))
|
|
|
|
;; Thanks to `doom-modeline'.
|
|
(defun dirvish--mode-line-bar-img (fullframe-p header)
|
|
"Create a bar image with height of `dirvish-mode-line-height'.
|
|
If FULLFRAME-P, use the `cdr' of the value as height, otherwise
|
|
use `car'. If HEADER, use `dirvish-header-line-height' instead."
|
|
(when (and (display-graphic-p) (image-type-available-p 'pbm)
|
|
(numberp dirvish-mode-line-bar-image-width))
|
|
(let ((ht (dirvish--mode-line-height fullframe-p header))
|
|
(wd dirvish-mode-line-bar-image-width))
|
|
(propertize
|
|
" " 'display
|
|
(ignore-errors
|
|
(create-image
|
|
(concat (format "P1\n%i %i\n" (if (eq wd 0) 1 wd) ht)
|
|
(make-string (* wd ht) (if (> wd 0) ?1 ?0)) "\n")
|
|
'pbm t :foreground "None" :ascent 'center))))))
|
|
|
|
(defun dirvish--setup-mode-line (dv)
|
|
"Setup the mode/header line for dirvish DV."
|
|
(let* ((idx-buf (cdr (dv-index dv)))
|
|
(hl (or (dirvish-prop :cus-header) (dv-header-line dv)))
|
|
(ml (dv-mode-line dv))
|
|
(fullframe-p (dv-curr-layout dv)))
|
|
(cond ; setup `header-line-format'
|
|
((and fullframe-p (not dirvish-use-header-line)))
|
|
(fullframe-p
|
|
(with-current-buffer idx-buf (setq header-line-format nil))
|
|
(with-current-buffer (dirvish--special-buffer 'header dv)
|
|
(setq header-line-format hl)))
|
|
(dirvish-use-header-line
|
|
(with-current-buffer idx-buf (setq header-line-format hl))))
|
|
(cond ; setup `mode-line-format'
|
|
((and fullframe-p (not dirvish-use-mode-line)))
|
|
(fullframe-p
|
|
(with-current-buffer idx-buf (setq mode-line-format nil))
|
|
(with-current-buffer (dirvish--special-buffer 'footer dv)
|
|
(setq mode-line-format ml)))
|
|
(dirvish-use-mode-line
|
|
(with-current-buffer idx-buf (setq mode-line-format ml))))))
|
|
|
|
;;;; Buffer Initialization
|
|
|
|
(defun dirvish--apply-hiding-p (ctx)
|
|
"Return t when it should hide cursor/details within context CTX."
|
|
(cond ((booleanp ctx) ctx)
|
|
((dirvish-prop :fd-info)
|
|
(memq 'dirvish-fd ctx))
|
|
((and (dirvish-curr) (dv-curr-layout (dirvish-curr)))
|
|
(memq 'dirvish ctx))
|
|
((and (dirvish-curr) (eq (dv-type (dirvish-curr)) 'side))
|
|
(memq 'dirvish-side ctx))
|
|
(t (memq 'dired ctx))))
|
|
|
|
(defun dirvish--subdir-offset ()
|
|
"Return number of lines occupied by subdir header."
|
|
(if (eq (bound-and-true-p dired-free-space) 'separate) 2 1))
|
|
|
|
(defun dirvish--maybe-toggle-cursor (&optional cursor)
|
|
"Toggle cursor's invisibility according to context.
|
|
Optionally, use CURSOR as the enabled cursor type."
|
|
(if (dirvish--apply-hiding-p dirvish-hide-cursor)
|
|
(prog1 (setq-local cursor-type nil)
|
|
(cond ((bound-and-true-p evil-local-mode)
|
|
(setq-local evil-normal-state-cursor '(bar . 0)))
|
|
((bound-and-true-p meow-motion-mode)
|
|
(setq-local meow-cursor-type-motion nil))))
|
|
(setq-local cursor-type (or cursor '(box . 4)))
|
|
(cond ((bound-and-true-p evil-local-mode)
|
|
(setq-local evil-normal-state-cursor (or cursor '(box . 4))))
|
|
((bound-and-true-p meow-motion-mode)
|
|
(setq-local meow-cursor-type-motion (or cursor '(box . 4)))))))
|
|
|
|
(defun dirvish--maybe-toggle-details ()
|
|
"Toggle `dired-hide-details-mode' according to context."
|
|
(if (dirvish--apply-hiding-p dirvish-hide-details)
|
|
(dired-hide-details-mode 1)
|
|
(dired-hide-details-mode -1)))
|
|
|
|
(defun dirvish--hide-dired-header ()
|
|
"Hide the Dired header."
|
|
(remove-overlays (point-min) (point) 'dired-header t)
|
|
(save-excursion
|
|
(let* ((beg (goto-char (point-min)))
|
|
(next-file (next-single-property-change beg 'dired-filename))
|
|
(end (or (dirvish-prop :content-begin)
|
|
(and (not next-file) (point-max))
|
|
(progn (goto-char next-file) (line-beginning-position))))
|
|
(o (make-overlay beg end)))
|
|
(dirvish-prop :content-begin end)
|
|
(overlay-put o 'dired-header t)
|
|
(overlay-put o 'invisible
|
|
(cond ((cdr dired-subdir-alist) nil)
|
|
(dirvish-use-header-line t))))))
|
|
|
|
(defun dirvish-pre-redisplay-h (window)
|
|
"Record root WINDOW and redisplay sessions in selected frame."
|
|
(setq dirvish--selected-window (frame-selected-window))
|
|
(when-let* ((dv (dirvish-curr))) (setf (dv-root-window dv) window))
|
|
(dirvish--redisplay))
|
|
|
|
(defun dirvish-post-command-h ()
|
|
"Reset cursor shape and position and update preview."
|
|
(cond ((not (dirvish--apply-hiding-p dirvish-hide-cursor)))
|
|
((eobp) (forward-line -1))
|
|
((cdr dired-subdir-alist))
|
|
((and (bobp) dirvish-use-header-line)
|
|
(goto-char (dirvish-prop :content-begin)))))
|
|
|
|
(defun dirvish-kill-buffer-h ()
|
|
"Remove buffer from session's roots, clear session when roots is empty."
|
|
(when-let* ((dv (dirvish-curr)) (buf (current-buffer)))
|
|
(setf (dv-roots dv) (cl-remove-if (lambda (i) (eq (cdr i) buf)) (dv-roots dv)))
|
|
(when (eq (cdr (dv-index dv)) buf) (setf (dv-index dv) (car (dv-roots dv))))
|
|
(if (dv-roots dv) ; killed by user in `ibuffer' or using `kill-current-buffer'
|
|
(when-let* ((win (dv-root-window dv))
|
|
((and (window-live-p win) (window-dedicated-p win))))
|
|
(with-selected-window win ; prevend this dedicated window get deleted
|
|
(dirvish-save-dedication (switch-to-buffer (cdr (dv-index dv))))))
|
|
(when-let* ((layout (dv-curr-layout dv)) (wc (dv-winconf dv)))
|
|
(cond ((eq buf (window-buffer (selected-window))) ; in a session, reset
|
|
(set-window-configuration wc nil t))
|
|
(t (cl-loop for tab in (funcall tab-bar-tabs-function)
|
|
for ws = (alist-get 'ws tab)
|
|
for bs = (window-state-buffers ws)
|
|
if (or (memq buf bs) (member (buffer-name buf) bs))
|
|
do (setf (alist-get 'wc tab) wc)))))
|
|
(mapc #'dirvish--kill-buffer (dv-preview-buffers dv))
|
|
(mapc #'dirvish--kill-buffer (dv-special-buffers dv))
|
|
(remhash (dv-id dv) dirvish--sessions))
|
|
(when (memq this-command ; clear lingering sessions when killing manually
|
|
'(kill-current-buffer ibuffer-do-kill-on-deletion-marks))
|
|
(cl-loop for b in (buffer-list) with rs = nil
|
|
unless (eq b buf) ; this buffer is not killed yet
|
|
if (with-current-buffer b (derived-mode-p 'dired-mode))
|
|
do (push b rs) ; in case there is any lingering sessions
|
|
finally do (unless rs (setq dirvish--sessions (dirvish--ht)))))))
|
|
|
|
(defun dirvish--setup-dired ()
|
|
"Initialize Dired buffers."
|
|
(use-local-map dirvish-mode-map)
|
|
(dirvish--hide-dired-header)
|
|
(dirvish--maybe-toggle-cursor 'box) ; restore from `wdired'
|
|
(setq-local dirvish--dir-data (or dirvish--dir-data (dirvish--ht))
|
|
revert-buffer-function (or (dirvish-prop :revert) #'dirvish-revert)
|
|
truncate-lines t dired-hide-details-hide-symlink-targets nil)
|
|
(add-hook 'pre-redisplay-functions #'dirvish-pre-redisplay-h nil t)
|
|
(add-hook 'window-buffer-change-functions #'dirvish-winbuf-change-h nil t)
|
|
(add-hook 'post-command-hook #'dirvish-post-command-h nil t)
|
|
(add-hook 'kill-buffer-hook #'dirvish-kill-buffer-h nil t))
|
|
|
|
(defun dirvish--create-parent-buffer (dv dir index level)
|
|
"Create parent buffer at DIR in DV selecting file INDEX.
|
|
LEVEL is the depth of current window."
|
|
(let* ((index (directory-file-name index))
|
|
(buf (dirvish--special-buffer (format "parent-%s" level) dv t))
|
|
(str (or (gethash dir (dv-parent-hash dv))
|
|
(let ((flags dired-actual-switches))
|
|
(with-temp-buffer (dired-insert-directory dir flags)
|
|
(buffer-string)))))
|
|
(attrs (mapcar #'car (dv-attributes dv)))
|
|
(icon (cond ((memq 'all-the-icons attrs) '(all-the-icons))
|
|
((memq 'nerd-icons attrs) '(nerd-icons))
|
|
((memq 'vscode-icon attrs) '(vscode-icon)))))
|
|
(cl-pushnew buf (dv-special-buffers dv))
|
|
(with-current-buffer buf
|
|
(dirvish-directory-view-mode)
|
|
(dirvish-prop :dv (dv-id dv))
|
|
(dirvish-prop :remote (file-remote-p dir))
|
|
(dirvish-prop :sudo ; copy this from root avoids requiring tramp
|
|
(with-current-buffer (cdr (dv-index dv)) (dirvish-prop :sudo)))
|
|
(puthash dir str (dv-parent-hash dv))
|
|
(let (buffer-read-only) (erase-buffer) (save-excursion (insert str)))
|
|
(setq-local dired-subdir-alist (list (cons dir (point-min-marker))))
|
|
(dired-goto-file-1 (file-name-nondirectory index) index (point-max))
|
|
(dirvish--maybe-toggle-cursor '(box . 0)) ; always hide cursor in parents
|
|
(dirvish-prop :attrs (dirvish--attrs-expand icon)) buf)))
|
|
|
|
(defun dirvish--init-special-buffers (dv)
|
|
"Initialize special buffers for DV."
|
|
(let ((dired (dirvish--special-buffer 'dired dv t))
|
|
(regular (dirvish--special-buffer 'preview dv t))
|
|
(shell (dirvish--special-buffer 'shell dv t))
|
|
(head (dirvish--special-buffer 'header dv))
|
|
(foot (dirvish--special-buffer 'footer dv))
|
|
(id (dv-id dv)))
|
|
(with-current-buffer dired
|
|
(dirvish-directory-view-mode) (dirvish-prop :dv id))
|
|
(with-current-buffer regular
|
|
(dirvish-special-preview-mode) (dirvish-prop :dv id))
|
|
(with-current-buffer shell
|
|
(dirvish-prop :dv id)
|
|
(dirvish-special-preview-mode)
|
|
(add-hook 'window-scroll-functions #'dirvish-apply-ansicolor-h nil t))
|
|
(with-current-buffer head (dirvish-misc-mode) (dirvish-prop :dv id))
|
|
(with-current-buffer foot (dirvish-misc-mode) (dirvish-prop :dv id))
|
|
(setf (dv-special-buffers dv) (list dired regular shell head foot))))
|
|
|
|
(defun dirvish--dir-data-async (dir buffer &optional inhibit-setup)
|
|
"Asynchronously fetch metadata for DIR, stored locally in BUFFER.
|
|
INHIBIT-SETUP is passed to `dirvish-data-for-dir'."
|
|
(dirvish--make-proc
|
|
`(prin1
|
|
(let ((hs (make-hash-table)) (bk ',(dirvish-prop :vc-backend)))
|
|
(if ,(and (not (dirvish-prop :sudo)) (dirvish-prop :remote)) (setq bk 0)
|
|
(dolist (f (ignore-errors ; `dir' can be problematic due to its encoding
|
|
(directory-files ,(file-local-name dir) t nil t 20000)))
|
|
(let* ((attrs (ignore-errors (file-attributes f))) (tp (nth 0 attrs)))
|
|
(cond ((eq t tp) (setq tp '(dir . nil)))
|
|
(tp (setq tp `(,(if (file-directory-p tp) 'dir 'file) . ,tp)))
|
|
(t (setq tp '(file . nil))))
|
|
(puthash (secure-hash 'md5 f) `(:builtin ,attrs :type ,tp) hs)))
|
|
(setq bk (or bk (vc-responsible-backend ,(file-local-name dir) t))))
|
|
(cons bk hs)))
|
|
(lambda (p _)
|
|
(pcase-let ((`(,buf . ,inhibit-setup) (process-get p 'meta))
|
|
(`(,pb . ,data) (cons (process-buffer p) nil)))
|
|
(condition-case err
|
|
(setq data (with-current-buffer pb (read (buffer-string))))
|
|
(error (message "Fetch dir data failed with error: %s" err)))
|
|
(when (buffer-live-p buf)
|
|
(with-current-buffer buf
|
|
(when-let* ((attrs (cdr data)) ((hash-table-p attrs)))
|
|
(maphash (lambda (k v) (puthash k v dirvish--dir-data)) attrs))
|
|
(dirvish-prop :vc-backend (or (car data) 0)) ; for &context compat
|
|
(dirvish-data-for-dir dir buf inhibit-setup))))
|
|
(delete-process p)
|
|
(dirvish--kill-buffer (process-buffer p)))
|
|
nil 'meta (cons buffer inhibit-setup)))
|
|
|
|
(cl-defgeneric dirvish-data-for-dir (dir buffer inhibit-setup)
|
|
"Fetch data for DIR in BUFFER.
|
|
It is called when DIR is in localhost and is not being
|
|
version-controlled. Run `dirvish-setup-hook' after data parsing unless
|
|
INHIBIT-SETUP is non-nil."
|
|
(when (buffer-live-p buffer)
|
|
(with-current-buffer buffer
|
|
(unless inhibit-setup (run-hooks 'dirvish-setup-hook))
|
|
(ignore dir))))
|
|
|
|
;;;; Layout Build & Teardown
|
|
|
|
(defun dirvish-revert (&optional ignore-auto _noconfirm)
|
|
"Reread the Dirvish buffer.
|
|
When IGNORE-AUTO, refresh file attributes as well.
|
|
Dirvish sets `revert-buffer-function' to this function."
|
|
(dirvish-prop :old-index (dired-get-filename nil t))
|
|
(let ((dv (dirvish-curr)))
|
|
(dirvish--check-dependencies dv) ; update dirvish setups
|
|
(dirvish-prop :attrs (dv-attributes dv)))
|
|
(dolist (keyword '(:free-space :content-begin)) (dirvish-prop keyword nil))
|
|
(dired-revert)
|
|
(dirvish--hide-dired-header)
|
|
(when ignore-auto ; meaning it is called interactively from user
|
|
(setq-local dirvish--dir-data (dirvish--ht))
|
|
(dirvish--dir-data-async (dirvish-prop :root) (current-buffer)))
|
|
(run-hooks 'dirvish-after-revert-hook))
|
|
|
|
(defun dirvish--redisplay ()
|
|
"Refresh UI for all session windows in selected frame."
|
|
(when-let* ((dv (dirvish-curr)) ((not (derived-mode-p 'wdired-mode)))
|
|
(r-win (dv-root-window dv)) ((window-live-p r-win)))
|
|
(when (dirvish--apply-hiding-p dirvish-hide-cursor) (dired-move-to-filename))
|
|
(dolist (w (window-list))
|
|
(when (and (not (eq r-win w))
|
|
(with-selected-window w (derived-mode-p 'dired-mode)))
|
|
(dirvish--render-attrs w)))
|
|
(dirvish--render-attrs r-win)
|
|
(when-let* ((idx (save-excursion (dired-get-filename nil t))))
|
|
(dirvish-prop :index (setq idx (file-local-name idx)))
|
|
(when (dv-curr-layout dv)
|
|
(dirvish--run-with-delay idx nil
|
|
(lambda (action)
|
|
;; don't grab focus when peeking or preview window is selected
|
|
(force-mode-line-update t)
|
|
(when (and (dirvish--selected-p dv)
|
|
(not (dirvish--get-session 'type 'peek)))
|
|
(dirvish--preview-update dv action))))))))
|
|
|
|
(defun dirvish-winbuf-change-h (window)
|
|
"Rebuild layout once buffer in WINDOW changed."
|
|
(when-let* ((dv (with-selected-window window (dirvish-curr)))
|
|
(dir (car (dv-index dv))) (buf (cdr (dv-index dv)))
|
|
(old-tab (with-selected-window window (dirvish-prop :tab)))
|
|
(old-frame (with-selected-window window (dirvish-prop :frame)))
|
|
(sc (cl-loop for (k v) on dirvish--scopes by 'cddr
|
|
append (list k (and (functionp v) (funcall v)))))
|
|
(layout t) (frame t) (tab t))
|
|
(setq layout (dv-curr-layout dv)
|
|
frame (plist-get sc :frame) tab (plist-get sc :tab))
|
|
(cl-flet ((killall (bufs) (mapc #'dirvish--kill-buffer bufs))
|
|
(build-dv (dv frame dir)
|
|
(with-selected-frame frame
|
|
(with-selected-window (dirvish--create-root-window dv)
|
|
(dirvish-save-dedication
|
|
(switch-to-buffer (get-buffer-create "*scratch*")))
|
|
(dirvish-save-dedication
|
|
(switch-to-buffer (dired-noselect dir)))
|
|
(dirvish--build-layout dv)))))
|
|
(cond ; created new tab / frame in a reused session, clear the old one
|
|
((not (equal old-frame frame))
|
|
(killall (append (list buf) (mapcar #'cdr (dv-roots dv))))
|
|
(build-dv (dirvish--new :curr-layout layout) frame dir))
|
|
((not (equal old-tab tab))
|
|
(tab-bar-switch-to-recent-tab)
|
|
(killall (append (list buf) (mapcar #'cdr (dv-roots dv))))
|
|
(tab-bar-switch-to-recent-tab)
|
|
(build-dv (dirvish--new :curr-layout layout) frame dir))
|
|
(t (with-selected-window window (dirvish--build-layout dv)))))))
|
|
|
|
(defun dirvish--create-parent-windows (dv)
|
|
"Create all dirvish parent windows for DV."
|
|
(let* ((current (expand-file-name default-directory))
|
|
(parent (dirvish--get-parent-path current))
|
|
(parent-dirs ())
|
|
(depth (or (car (dv-curr-layout dv)) 0))
|
|
(i 0))
|
|
(while (and (< i depth) (not (string= current parent)))
|
|
(cl-incf i)
|
|
(push (cons current parent) parent-dirs)
|
|
(setq current (dirvish--get-parent-path current))
|
|
(setq parent (dirvish--get-parent-path parent)))
|
|
(when (> depth 0)
|
|
(cl-loop with layout = (dv-curr-layout dv)
|
|
with parent-width = (nth 1 layout)
|
|
with remain = (- 1 (nth 2 layout) parent-width)
|
|
with width = (min (/ remain depth) parent-width)
|
|
for level from 1 for (current . parent) in parent-dirs
|
|
for args = `((side . left) (inhibit-same-window . t)
|
|
(window-width . ,width)
|
|
(window-parameters . ((no-other-window . t))))
|
|
for b = (dirvish--create-parent-buffer dv parent current level)
|
|
for w = (display-buffer b `(dirvish--display-buffer . ,args)) do
|
|
(dirvish--render-attrs w 'never) ; only render icon
|
|
(with-selected-window w
|
|
(set-window-fringes w 1 1) (set-window-dedicated-p w t))))))
|
|
|
|
(defun dirvish--window-split-order ()
|
|
"Compute the window split order."
|
|
(let* ((weights '((nil . 0) (t . 1) (global . 2)))
|
|
(ord
|
|
'((00 preview) (12 footer preview header) (21 header preview footer)
|
|
(20 header preview) (11 preview header footer) (10 preview header)
|
|
(01 preview footer) (02 footer preview) (22 footer header preview)))
|
|
(h-pos (if (dirvish-prop :global-header) 2
|
|
(alist-get dirvish-use-header-line weights)))
|
|
(m-pos (alist-get dirvish-use-mode-line weights))
|
|
(key (string-to-number (format "%s%s" (or h-pos 1) (or m-pos 1)))))
|
|
(cdr (assq key ord))))
|
|
|
|
(defun dirvish--build-layout (dv)
|
|
"Build layout for Dirvish session DV."
|
|
(let* ((layout (dv-curr-layout dv)) (conf (dv-winconf dv))
|
|
(w-args `((preview (side . right) (window-width . ,(nth 2 layout)))
|
|
(header (side . above) (window-height . -2)
|
|
(window-parameters . ((no-other-window . t))))
|
|
(footer (side . below) (window-height . -2)
|
|
(window-parameters . ((no-other-window . t))))))
|
|
(w-order (and layout (dirvish--window-split-order)))
|
|
(window-safe-min-height 0) (window-resize-pixelwise t)
|
|
(lh (line-pixel-height)) (gui? (display-graphic-p)) sf
|
|
(mh (dirvish--mode-line-height t)) (hh (dirvish--mode-line-height t t)))
|
|
(setf (dv-index dv) (cons (dirvish-prop :root) (current-buffer)))
|
|
;; only refresh window config before creating fullframe layout
|
|
(setf (dv-winconf dv) (when layout (or conf (current-window-configuration))))
|
|
(and (not layout) (setq sf (dv-size-fixed dv)) (setq window-size-fixed sf))
|
|
(when layout (dirvish--init-special-buffers dv))
|
|
(dirvish--setup-mode-line dv)
|
|
(when w-order (let ((ignore-window-parameters t)) (delete-other-windows)))
|
|
(when (or (dv-curr-layout dv) (dv-dedicated dv))
|
|
(set-window-dedicated-p nil t))
|
|
;; ensure a positive fringe on both sides for `dirvish-subtree' (#311)
|
|
(set-window-fringes nil (1+ dirvish-window-fringe) 1)
|
|
(dolist (pane w-order)
|
|
(let* ((buf (dirvish--special-buffer pane dv (eq pane 'preview)))
|
|
(args (alist-get pane w-args))
|
|
(win (display-buffer buf `(dirvish--display-buffer . ,args))))
|
|
(pcase pane
|
|
('preview (setf (dv-preview-window dv) win))
|
|
('header (when (and gui? (> hh lh)) (fit-window-to-buffer win 2 1)))
|
|
('footer (when (and gui? (> mh lh)) (fit-window-to-buffer win 2 1))))
|
|
(unless (eq pane 'preview) (set-window-dedicated-p win t))
|
|
(set-window-buffer win buf)))
|
|
(dirvish--create-parent-windows dv)
|
|
(dirvish--run-with-delay 'reset) ; preview initialization
|
|
(dirvish--maybe-toggle-cursor)
|
|
(dirvish--maybe-toggle-details)))
|
|
|
|
;;;; Major modes
|
|
|
|
(define-derived-mode dirvish-directory-view-mode special-mode "Dirvish DIRview"
|
|
"Major mode for parent directory and directory preview buffer."
|
|
(setq-local mode-line-format nil header-line-format nil truncate-lines t
|
|
dirvish--dir-data (dirvish--ht) font-lock-defaults
|
|
'(dired-font-lock-keywords t nil nil beginning-of-line))
|
|
(font-lock-mode 1)
|
|
:group 'dirvish :interactive nil)
|
|
|
|
(define-derived-mode dirvish-special-preview-mode special-mode "Dirvish Special"
|
|
"Major mode for info, shell command output and non-text file preview buffer."
|
|
(setq-local mode-line-format nil header-line-format nil)
|
|
:group 'dirvish :interactive nil)
|
|
|
|
(define-derived-mode dirvish-misc-mode special-mode "Dirvish Misc"
|
|
"Major mode for mode/header-line and other special buffers."
|
|
(setq-local face-remapping-alist '((header-line-inactive header-line)
|
|
(mode-line-inactive mode-line))
|
|
cursor-type nil window-size-fixed 'height
|
|
mode-line-format nil header-line-format nil)
|
|
:group 'dirvish :interactive nil)
|
|
|
|
;;;; Advices
|
|
|
|
(defun dirvish-insert-subdir-a (dirname &rest _)
|
|
"Setup newly inserted subdir DIRNAME for this Dirvish buffer."
|
|
(dirvish--hide-dired-header)
|
|
(dirvish--dir-data-async dirname (current-buffer) t))
|
|
|
|
(defun dirvish-wdired-enter-a (&rest _)
|
|
"Advice for `wdired-change-to-wdired-mode'."
|
|
(let (dirvish-hide-cursor) (dirvish--maybe-toggle-cursor 'hollow))
|
|
(dolist (ov '(dirvish-a-ov dirvish-l-ov dirvish-r-ov))
|
|
(remove-overlays (point-min) (point-max) ov t)))
|
|
|
|
(defun dirvish-find-alt-a ()
|
|
"Advice for `dired-find-alternate-file'."
|
|
(dirvish--find-entry 'find-alternate-file (dired-get-file-for-visit)))
|
|
|
|
(defun dirvish-find-marked-files-a (&optional noselect)
|
|
"Find all marked files displaying all of them simultaneously.
|
|
With optional NOSELECT just find files but do not select them."
|
|
(declare-function dired-simultaneous-find-file "dired-x")
|
|
(when-let* ((dv (dirvish-curr))
|
|
(files (dired-get-marked-files nil nil nil nil t)))
|
|
(unless noselect (dirvish--clear-session dv))
|
|
(mapc #'dirvish--kill-buffer (dv-preview-buffers dv))
|
|
(dired-simultaneous-find-file files noselect)))
|
|
|
|
(defun dirvish-dired-noselect-a (fn dir-or-list &optional flags re)
|
|
"Return buffer for DIR-OR-LIST with FLAGS, FN is `dired-noselect'."
|
|
(let* ((dir (if (consp dir-or-list) (car dir-or-list) dir-or-list))
|
|
(key (file-name-as-directory (expand-file-name dir)))
|
|
(dvc (dirvish-curr))
|
|
(dv (if (and dvc (not (eq (dv-type dvc) 'peek))) dvc
|
|
(or (dirvish--get-session) (dirvish--new))))
|
|
(bname buffer-file-name) (remote (file-remote-p dir))
|
|
(flags (or flags (dv-ls-switches dv)))
|
|
(mc dirvish-large-directory-threshold)
|
|
(buffer (alist-get key (dv-roots dv) nil nil #'equal))
|
|
(new? (null buffer)) (dps (dv-preview-dispatchers dv))
|
|
(hist (cons key nil)) tramp fd)
|
|
(setf (dv-timestamp dv) (dirvish--timestamp))
|
|
(cond ((and new? remote)
|
|
(setq tramp (prog1 'dirvish-tramp-noselect (require 'dirvish-tramp))
|
|
buffer (apply tramp (list fn dir-or-list flags remote dps))))
|
|
((or re (and mc (length> (directory-files key nil nil t mc) (1- mc))))
|
|
(setq fd (prog1 'dirvish-fd-noselect (require 'dirvish-fd nil t))
|
|
buffer (apply fd (list dv key (or re "")))
|
|
re (if (stringp re) re (mapconcat #'concat re ","))
|
|
key (concat key "🔍" re)))
|
|
(new? (let (dired-buffers) ; disable reuse from `dired'
|
|
(setq buffer (apply fn (list dir-or-list flags))))))
|
|
(when (setq new? (null (alist-get key (dv-roots dv) nil nil #'equal)))
|
|
(push (cons key buffer) (dv-roots dv)))
|
|
(unless (member (car hist) (mapcar #'car dired-buffers))
|
|
(setq dired-buffers (seq-take (push hist dired-buffers) 20000)))
|
|
(setcdr (assoc (car hist) dired-buffers) buffer)
|
|
(with-current-buffer buffer
|
|
(dirvish--setup-dired)
|
|
(funcall (dv-root-conf dv) buffer)
|
|
(dirvish-prop :dv (dv-id dv))
|
|
(dirvish-prop :gui (display-graphic-p))
|
|
(dirvish-prop :remote remote)
|
|
(dirvish-prop :root key)
|
|
(unless remote (dirvish-prop :preview-dps dps))
|
|
(dirvish-prop :attrs (dv-attributes dv))
|
|
(cl-loop for (k v) on dirvish--scopes by 'cddr
|
|
do (dirvish-prop k (and (functionp v) (funcall v))))
|
|
(when new? (dirvish--dir-data-async (car hist) buffer))
|
|
(when bname (dired-goto-file bname))
|
|
(setf (dv-index dv) (cons key buffer))
|
|
(run-hook-with-args 'dirvish-find-entry-hook (car hist) 'dired)
|
|
buffer)))
|
|
|
|
;;;; Commands
|
|
|
|
(defun dirvish-layout-toggle ()
|
|
"Toggle layout of current Dirvish session.
|
|
A session with layout means it has a companion preview window and
|
|
possibly one or more parent windows."
|
|
(interactive)
|
|
(let* ((dv (or (dirvish-curr) (user-error "Not a dirvish buffer")))
|
|
(old-layout (dv-curr-layout dv)) (conf (dv-winconf dv))
|
|
(new-layout (unless old-layout (dv-ff-layout dv)))
|
|
(buf (current-buffer)))
|
|
(setf (dv-preview-hash dv) (dirvish--ht) (dv-parent-hash dv) (dirvish--ht))
|
|
(if old-layout (and conf (set-window-configuration conf))
|
|
(with-selected-window (dv-root-window dv) (quit-window)))
|
|
(setf (dv-curr-layout dv) new-layout)
|
|
(with-selected-window (dirvish--create-root-window dv)
|
|
(dirvish-save-dedication (switch-to-buffer buf))
|
|
(dirvish--build-layout dv))))
|
|
|
|
(defun dirvish-quit ()
|
|
"Quit current Dirvish session.
|
|
If the session is a full-framed one, the window layout is restored. If
|
|
`dirvish-reuse-session' is nil, all Dired buffers in the session are
|
|
killed, otherwise only the invisible Dired buffers within the session
|
|
are killed and the Dired buffer(s) in the selected window are buried."
|
|
(interactive)
|
|
(when-let* ((dv (dirvish-curr)) (ct 0) (max-c (length (dv-roots dv))))
|
|
(dirvish--clear-session dv t)
|
|
(while (and (dirvish-curr) (<= ct max-c)) (cl-incf ct) (quit-window))))
|
|
|
|
;;;###autoload
|
|
(define-minor-mode dirvish-override-dired-mode
|
|
"Let Dirvish take over Dired globally."
|
|
:group 'dirvish :global t
|
|
(let ((ads '((dired--find-file dirvish--find-entry :override)
|
|
(dired-find-alternate-file dirvish-find-alt-a :override)
|
|
(dired-do-find-marked-files dirvish-find-marked-files-a :override)
|
|
(dired-noselect dirvish-dired-noselect-a :around)
|
|
(dired-insert-subdir dirvish-insert-subdir-a :after)
|
|
(wdired-change-to-wdired-mode dirvish-wdired-enter-a :after)
|
|
(wdired-change-to-dired-mode dirvish--setup-dired :after))))
|
|
(if dirvish-override-dired-mode
|
|
(pcase-dolist (`(,sym ,fn ,how) ads) (advice-add sym how fn))
|
|
(pcase-dolist (`(,sym ,fn) ads) (advice-remove sym fn)))))
|
|
|
|
(defun dirvish--try-reuse (path &optional dwim)
|
|
"Find PATH in existed or new session, DWIM is passed from `dirvish-dwim'."
|
|
(let* ((dir (or path default-directory))
|
|
(fn (if dired-kill-when-opening-new-dired-buffer 'find-alternate-file
|
|
'find-file))
|
|
(cur? (dirvish-curr)) ; can be a non-default session, reuse it directly
|
|
(vis? (cl-loop for w in (window-list)
|
|
for b = (window-buffer w)
|
|
for dv = (with-current-buffer b (dirvish-curr))
|
|
thereis (and dv (eq 'default (dv-type dv)) dv)))
|
|
(reuse? (unless vis? (dirvish--get-session 'type 'default))))
|
|
(cond (cur? (dirvish--find-entry fn dir)
|
|
(when (and dirvish-default-layout (not (dv-curr-layout cur?)))
|
|
(unless dwim (dirvish-layout-toggle))))
|
|
(vis?
|
|
(dirvish-save-dedication (switch-to-buffer (cdr (dv-index vis?))))
|
|
(dirvish--find-entry fn dir)
|
|
(when (and dirvish-default-layout (not (dv-curr-layout vis?)))
|
|
(unless dwim (dirvish-layout-toggle))))
|
|
(reuse?
|
|
(with-selected-window (dirvish--create-root-window reuse?)
|
|
(setf (dv-curr-layout reuse?)
|
|
(or (dv-curr-layout reuse?) dirvish-default-layout))
|
|
(and dwim (not (one-window-p)) (setf (dv-curr-layout reuse?) nil))
|
|
(dirvish-save-dedication (switch-to-buffer (cdr (dv-index reuse?))))
|
|
(unless (eq dirvish-reuse-session 'resume)
|
|
(dirvish--find-entry fn dir))))
|
|
(t (dirvish--new
|
|
:curr-layout (if dwim (and (one-window-p) dirvish-default-layout)
|
|
dirvish-default-layout))
|
|
(dirvish--find-entry 'find-file dir)))))
|
|
|
|
;;;###autoload
|
|
(defun dirvish (&optional path)
|
|
"Open PATH in a fullframe Dirvish session.
|
|
Prompt for PATH if called with \\[universal-arguments], otherwise PATH
|
|
defaults to `default-directory'."
|
|
(interactive (list (and current-prefix-arg (read-directory-name "Dirvish: "))))
|
|
(dirvish--try-reuse path))
|
|
|
|
;;;###autoload
|
|
(defun dirvish-dwim (&optional path)
|
|
"Open PATH in a fullframe session if selected window is the only window.
|
|
Prompt for PATH if called with \\[universal-arguments], otherwise PATH
|
|
defaults to `default-directory'. If there are other windows exist in the
|
|
selected frame, the session occupies only the selected window."
|
|
(interactive (list (and current-prefix-arg (read-directory-name "Dirvish: "))))
|
|
(dirvish--try-reuse path 'dwim))
|
|
|
|
(provide 'dirvish)
|
|
;;; dirvish.el ends here
|