daniel/emacs
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

add package dependencies

Browse Source
This commit is contained in:
Daniel Weschke
2025-07-06 21:26:51 +02:00
parent 65dedd3df8
commit 807d0f28f6
23 changed files with 8249 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

577
lisp/dirvish/dirvish-emerge.el Normal file
View File

@@ -0,0 +1,577 @@
;;; dirvish-emerge.el --- Pin files you are interested in at top -*- lexical-binding: t -*-
;; Copyright (C) 2021-2025 Alex Lu
;; Author : Alex Lu <https://github.com/alexluigit>
;; Keywords: files, convenience
;; Homepage: https://github.com/alexluigit/dirvish
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; This extension allows user to pin important files at the top of Dirvish
;; buffers. Type M-x dirvish-emerge-menu RET into a dirvish buffer to get
;; started.
;;; Code:
(declare-function dirvish-emerge--menu "dirvish-emerge")
(require 'dirvish)
(require 'transient)
(defun dirvish-emerge-safe-groups-p (groups)
"Return t if GROUPS is a list and has less than 100 items."
(and (listp groups) (< (length groups) 100)))
(defcustom dirvish-emerge-groups '()
"Default emerge groups applied to all Dirvish buffer.
The value is an alist of (NAME . (TYPE . VALUE)) where NAME is a
string to designate the name and display title of the group, TYPE
is a symbol in one of `predicate', `extensions', or `regex'. The
corresponding VALUEs (criteria) for these types are:
- `predicate': a symbol that points to a predicate
- `extensions': one or more filename extensions
- `regex': a regular expression
The predicates are defined by `dirvish-emerge-define-predicate'.
Here is a sample value for this variable.
\((\"Recent\" (predicate . `recent-files-2h'))
(\"README\" (regex . \"README\"))
(\"PDF\" (extensions \"pdf\"))
(\"LaTeX\" (extensions \"tex\" \"bib\")))
When `dirvish-emerge-mode' is enabled in the buffer, the fileset
in the buffer are separated and rearranged by the following groups:
1. files modified within 2 hours
2. files whose name can be matched by \"README\"
3. files whose extension is \"pdf\"
4. files whose extension is \"tex\" or \"bib\"
5. other files
Although you can set this variable globally, a more appropriate
way would be set it directory locally. In that case, it is
recommended to compose and save this variable to .dir-locals.el
by the help of `dirvish-emerge-menu'."
:group 'dirvish :type 'alist)
(put 'dirvish-emerge-groups 'safe-local-variable #'dirvish-emerge-safe-groups-p)
(defcustom dirvish-emerge-max-file-count 20000
"Inhibit auto grouping in big directories.
If file count of the directory is greater than this value,
automatic grouping is disabled even if `dirvish-emerge-mode' is
turned on in the buffer."
:group 'dirvish :type 'integer)
(defface dirvish-emerge-group-title
'((t :inherit dired-ignored))
"Face used for emerge group title."
:group 'dirvish)
(defclass dirvish-emerge-group (transient-infix)
((hide :initarg :hide)
(selected :initarg :selected)
(recipe :initarg :recipe))
"[Experimental] Class for Dirvish emerge groups.")
(defvar-local dirvish-emerge--group-overlays nil)
(cl-defmethod transient-format-key ((obj dirvish-emerge-group))
"Format key for OBJ."
(let ((key (oref obj key))
(sel (oref obj selected)))
(propertize key 'face (if sel 'transient-value 'transient-key))))
(cl-defmethod transient-format-description ((obj dirvish-emerge-group))
"Format description for OBJ."
(let ((desc (oref obj description))
(sel (oref obj selected)))
(propertize desc 'face (and sel 'transient-value))))
(cl-defmethod transient-format-value ((obj dirvish-emerge-group))
"Format value for OBJ."
(pcase-let* ((`(,type . ,val) (oref obj recipe))
(face (if (oref obj hide) 'font-lock-comment-face
'transient-argument)))
(pcase type
('regex (propertize (format "\"%s\"" val) 'face face))
('extensions (propertize (format "%s" (mapconcat #'concat val ","))
'face face))
('predicate (propertize "PRED" 'face face)))))
(cl-defmethod transient-infix-read ((obj dirvish-emerge-group))
"Read value from OBJ."
(oset obj value (list (oref obj description) (oref obj recipe)
(oref obj hide) (oref obj selected))))
(cl-defmethod transient-infix-set ((obj dirvish-emerge-group) _value)
"Set value for OBJ."
(if-let* ((sel (oref obj selected)))
(dirvish-emerge-read-recipe (oref obj recipe) obj)
(oset obj selected t)))
(defvar dirvish-emerge--max-pred-name-len 0)
(defvar dirvish-emerge--available-preds '())
(defmacro dirvish-emerge-define-predicate (name docstring &rest body)
"Define a group predicate NAME with BODY.
DOCSTRING is the documentation of the predicate.
The predicate takes the following arguments:
- `local-name': output from (file-name-nondirectory FILE)
- `full-name': output from (dired-get-filename)
- `type': a cons of (TYPE . SYM-TARGET). TYPE is either `dir' or
`file'. SYM-TARGET is the symlink target as a string when the
file is a symlink, otherwise nil.
- `attrs': output from (file-attributes FILE)
The predicate is consumed by `dirvish-emerge-groups'."
(declare (indent defun) (doc-string 2))
`(let* ((fn (lambda (local-name full-name type attrs)
(ignore local-name full-name type attrs) ,@body))
(pair (assq ',name dirvish-emerge--available-preds))
(val (cons ',name (cons fn ,docstring))))
(setf dirvish-emerge--max-pred-name-len
(max dirvish-emerge--max-pred-name-len
(length (format "%s" ',name))))
(if pair
(setcdr (assq ',name dirvish-emerge--available-preds) val)
(push val dirvish-emerge--available-preds))))
(dirvish-emerge-define-predicate recent-files-2h
"File modified within 2 hours."
(let ((mtime (file-attribute-modification-time attrs)))
(and (listp mtime)
(< (float-time (time-subtract (current-time) mtime)) 7200))))
(dirvish-emerge-define-predicate recent-files-today
"File modified today."
(let ((mtime (file-attribute-modification-time attrs)))
(and (listp mtime)
(< (float-time (time-subtract (current-time) mtime)) 86400))))
(dirvish-emerge-define-predicate directories
"Matches directories."
(eq 'dir (car type)))
(dirvish-emerge-define-predicate files
"Matches files."
(eq 'file (car type)))
(dirvish-emerge-define-predicate symlinks
"Matches symlimks."
(cdr type))
;; Note the behavior of this predicate doesn't exactly match `file-executable-p'.
;; It checks if the owner of the file can execute it and not if the current
;; user can.
(dirvish-emerge-define-predicate executables
"Matches executables."
(eq ?x (aref (file-attribute-modes attrs) 3)))
(cl-defgeneric dirvish-emerge-read-recipe (recipe &optional obj)
"Read RECIPE from user input and optionally save it to OBJ.")
(cl-defmethod dirvish-emerge-read-recipe ((recipe (head regex)) &optional obj)
"Read RECIPE from user input and optionally save it to OBJ."
(let* ((deft (cdr recipe))
(regex (read-regexp
(format "Change regex to (defaults to %s): " deft) deft)))
(if obj (oset obj recipe `(regex . ,regex)) regex)))
(cl-defmethod dirvish-emerge-read-recipe ((recipe (head extensions)) &optional obj)
"Read RECIPE from user input and optionally save it to OBJ."
(let* ((prompt "Input one or more extensions: ")
(cands
(cl-remove-if-not (lambda (i) (and i (> (length i) 0)))
(mapcar #'file-name-extension
(directory-files default-directory))))
(exts (completing-read-multiple
prompt cands nil nil (mapconcat #'concat (cdr recipe) ","))))
(if obj (oset obj recipe `(extensions . ,@exts)) exts)))
(cl-defmethod dirvish-emerge-read-recipe ((recipe (head predicate)) &optional obj)
"Read RECIPE from user input and optionally save it to OBJ."
(ignore recipe)
(let* ((table dirvish-emerge--available-preds)
(fn (lambda (i)
(let ((item (intern (format "%s" i))))
(concat
(make-string
(- dirvish-emerge--max-pred-name-len (length i) -8) ?\s)
(cddr (assq item table))))))
(coll (dirvish--completion-table-with-metadata
table `((annotation-function . ,fn))))
(pred (completing-read "Predicate: " coll)))
(if obj (oset obj recipe `(predicate . ,(read pred))) (read pred))))
(defsubst dirvish-emerge--make-pred (recipe)
"Make predicate function from RECIPE."
(pcase-let ((`(,type . ,val) recipe))
(pcase type
('regex
`(lambda (local-name _ _ _) (string-match ,val local-name)))
('extensions
(let ((exts (format "\\.\\(%s\\)$" (mapconcat #'concat val "\\|"))))
`(lambda (local-name _ _ _) (string-match ,exts local-name))))
('predicate
(cadr (assq (cdr recipe) dirvish-emerge--available-preds))))))
(defun dirvish-emerge--update-groups (groups)
"Update dir-local groups to GROUPS."
(setq-local dirvish-emerge-groups groups)
(setf (alist-get 'dirvish-emerge-groups
(alist-get
'dirvish-mode
(alist-get (expand-file-name default-directory)
dir-locals-class-alist nil nil #'string=)))
groups))
(defun dirvish-emerge--create-infix
(ifx description recipe &optional selected hide)
"Create an transient infix IFX of emerge group.
DESCRIPTION, RECIPE, SELECTED and HIDE are inserted into the
corresponding slots."
(eval `(transient-define-infix ,ifx ()
:class 'dirvish-emerge-group
:recipe ',recipe
:selected ,selected
:hide ,hide
:description ,description)))
(defun dirvish-emerge--create-infixes ()
"Define and collect emerge groups from `dirvish-emerge-groups'."
(cl-loop with len = (length dirvish-emerge-groups)
for idx from 0
for (desc recipe hide selected) in (seq-take dirvish-emerge-groups 99)
for ifx = (intern (format "dirvish-%s-infix"
(replace-regexp-in-string " " "-" desc)))
for key = (format (if (> len 10) "%02i" "%i") idx)
collect (progn
(dirvish-emerge--create-infix
ifx desc recipe selected hide)
(list key ifx))))
(defun dirvish-emerge--ifx-apply ()
"Apply emerge infixes in `transient-current-suffixes'."
(let* ((ifxes (cl-loop for o in transient-current-suffixes
when (eq (type-of o) 'dirvish-emerge-group)
collect o))
(groups (cl-loop for o in ifxes
collect (list (oref o description) (oref o recipe)
(oref o hide) (oref o selected)))))
(dirvish-emerge-mode 1)
(revert-buffer)
(dirvish-prop :force-emerge t)
(setq-local dirvish-emerge-groups groups)))
(defun dirvish-emerge--ifx-unselect ()
"Unselect selected emerge groups."
(cl-loop for obj in transient-current-suffixes
when (eq (type-of obj) 'dirvish-emerge-group)
do (oset obj selected nil)))
(defun dirvish-emerge--ifx-toggle-hiding ()
"Hide selected emerge groups."
(cl-loop for obj in transient-current-suffixes
when (and (eq (type-of obj) 'dirvish-emerge-group)
(oref obj selected))
do (oset obj hide (not (oref obj hide)))))
(defun dirvish-emerge--ifx-add ()
"Add a new emerge group to `transient-current-suffixes'."
(let ((type (pcase (read-char-choice
"Press e for extensions, p for predicate, r for regex: "
'(?e ?p ?r))
(101 'extensions) (112 'predicate) ('114 'regex)))
(names (mapcar #'car dirvish-emerge-groups))
(groups (buffer-local-value 'dirvish-emerge-groups (current-buffer)))
(idx 1) (default "Anon-1") recipe title)
(while (member default names)
(cl-incf idx)
(setq default (format "Anon-%s" idx)))
(setq recipe (dirvish-emerge-read-recipe (cons type nil)))
(setq title (read-string "Group title: " default))
(push (list title (cons type recipe)) groups)
(dirvish-emerge--update-groups groups)
(dirvish-emerge-menu)))
(defun dirvish-emerge--ifx-remove ()
"Remove an emerge group from `transient-current-suffixes'."
(cl-loop for obj in transient-current-suffixes
when (and (eq (type-of obj) 'dirvish-emerge-group)
(oref obj selected))
do (dirvish-emerge--update-groups
(assoc-delete-all (oref obj description)
dirvish-emerge-groups #'equal)))
(dirvish-emerge-menu))
(defun dirvish-emerge--ifx-promote (&optional demote)
"Shift selected emerge groups the highest position.
If DEMOTE, shift them to the lowest instead."
(cl-loop with sel = ()
for obj in transient-current-suffixes
when (and (eq (type-of obj) 'dirvish-emerge-group)
(oref obj selected))
do (progn (push obj sel)
(setf dirvish-emerge-groups
(assoc-delete-all
(oref obj description)
dirvish-emerge-groups #'equal)))
finally
(let* ((sel (cl-loop for o in (reverse sel) collect
(list (oref o description) (oref o recipe)
(oref o hide) (oref o selected))))
(groups (if demote (append dirvish-emerge-groups sel)
(append sel dirvish-emerge-groups))))
(dirvish-emerge--update-groups groups)))
(dirvish-emerge-menu))
(defun dirvish-emerge--ifx-read ()
"Read groups from .dir-locals.el."
(dirvish-emerge--readin-groups-1 t)
(dirvish-emerge-menu))
(defun dirvish-emerge--ifx-write ()
"Write groups to .dir-locals.el."
(add-dir-local-variable
'dired-mode 'dirvish-emerge-groups
(cl-loop for o in transient-current-suffixes
when (eq (type-of o) 'dirvish-emerge-group) collect
(list (oref o description) (oref o recipe)
(oref o hide) (oref o selected)))))
(defun dirvish-emerge--readin-groups-1 (&optional re-read)
"Helper for `dirvish-emerge--readin-groups'.
When RE-READ, read groups from .dir-locals.el regardless of cache."
(let ((dir-locals-directory-cache
(if re-read nil dir-locals-directory-cache)))
(hack-dir-local-variables))
(let* ((dir-local (cdr (assq 'dirvish-emerge-groups
file-local-variables-alist)))
(groups
(cond (re-read dir-local)
((local-variable-if-set-p 'dirvish-emerge-groups)
(buffer-local-value 'dirvish-emerge-groups (current-buffer)))
(dir-local dir-local)
(t (default-value 'dirvish-emerge-groups)))))
(hack-one-local-variable 'dirvish-emerge-groups groups)
(dirvish-prop :emerge-preds
(cl-loop for idx from 0 to (1- (length groups))
for (_desc recipe) in groups collect
(cons idx (dirvish-emerge--make-pred recipe))))))
(defun dirvish-emerge--readin-groups (&optional _dv _entry buffer)
"Readin emerge groups in BUFFER for session DV."
(with-current-buffer (or buffer (current-buffer))
(dirvish-emerge--readin-groups-1)))
(defvar dirvish-emerge-group-heading-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "TAB") 'dirvish-emerge-toggle-current-group)
map)
"Keymap used when over a group heading.")
(defun dirvish-emerge--group-heading (desc hide)
"Format emerge group heading in Dirvish buffer.
DESC and HIDE are the group title and visibility respectively."
(let ((prefix (propertize " " 'font-lock-face
'(:inherit dirvish-emerge-group-title
:strike-through t)))
(title (propertize (format " %s%s " desc (if hide " (Hidden)" ""))
'font-lock-face 'dirvish-emerge-group-title))
(suffix (propertize " " 'display '(space :align-to right)
'font-lock-face
'(:inherit dirvish-emerge-group-title
:strike-through t))))
(propertize (format "%s%s%s\n" prefix title suffix)
'keymap dirvish-emerge-group-heading-map)))
(defun dirvish-emerge--insert-group (group)
"Insert an individual GROUP to buffer."
(pcase-let* ((`(,idx ,desc ,hide ,files) group)
(beg (point)) (empty nil))
(when (listp files)
(setq empty (not files)
files (mapconcat #'concat (nreverse files) "")))
(unless empty (insert (dirvish-emerge--group-heading desc hide)))
(unless hide (insert files))
(let ((o (make-overlay beg (point))))
(overlay-put o 'evaporate t)
(overlay-put o 'dirvish-emerge
(list idx desc hide (unless empty files) empty))
(push o dirvish-emerge--group-overlays))))
(defun dirvish-emerge--insert-groups (groups &optional pos beg end)
"Insert GROUPS then resume cursor to POS.
POS can be a integer or filename.
BEG and END determine the boundary of groups."
(unless (or beg end)
(setq beg (dirvish-prop :content-begin)
end (- (dired-subdir-max) (if (cdr dired-subdir-alist) 1 0))))
(with-silent-modifications
(setq dirvish-emerge--group-overlays nil)
(delete-region beg end)
(mapc #'dirvish-emerge--insert-group groups)
(setq dirvish-emerge--group-overlays
(nreverse dirvish-emerge--group-overlays)))
(cond ((numberp pos) (goto-char pos))
((stringp pos) (dired-goto-file pos))))
(defun dirvish-emerge--apply-1 (preds)
"Helper for `dirvish-emerge--apply'.
PREDS are locally composed predicates."
(let ((old-file (dirvish-prop :index))
(groups (cl-loop
with grs = (append dirvish-emerge-groups
'(("-" nil nil)))
for i from 0
for (desc _ hide) in grs
collect (list i desc hide '())))
(beg (progn (goto-char (point-min)) (dirvish-prop :content-begin)))
(end (- (dired-subdir-max) (if (cdr dired-subdir-alist) 1 0)))
(max-idx (length preds))
(dir (file-local-name (dired-current-directory))))
(while (< (point) end)
(when-let* ((f-beg (dired-move-to-filename))
(f-end (dired-move-to-end-of-filename)))
(let* ((l-beg (line-beginning-position))
(l-end (1+ (line-end-position)))
(local (buffer-substring-no-properties f-beg f-end))
(full (concat dir local))
(type (dirvish-attribute-cache full :type))
(attrs (dirvish-attribute-cache full :builtin))
(match (cl-loop for (index . fn) in preds
for match = (funcall fn local full type attrs)
thereis (and match index))))
(push (buffer-substring-no-properties l-beg l-end)
(nth 3 (nth (or match max-idx) groups)))))
(forward-line 1))
(dirvish-emerge--insert-groups groups old-file beg end)))
(defun dirvish-emerge--apply ()
"Readin `dirvish-emerge-groups' and apply them."
(when (and (not (dirvish-prop :fd-info))
(or (dirvish-prop :force-emerge)
(< (hash-table-count dirvish--dir-data)
dirvish-emerge-max-file-count)))
(dirvish-emerge--readin-groups)
(when-let* ((preds (dirvish-prop :emerge-preds)))
(dirvish-emerge--apply-1 preds))))
;;;; Interactive commands
;;;###autoload
(defun dirvish-emerge-menu ()
"Manage pinned files in Dirvish."
(interactive)
(dirvish-emerge--readin-groups)
(eval
`(transient-define-prefix dirvish-emerge--menu ()
"Manage pinned files in Dirvish."
[:description
(lambda () (dirvish--format-menu-heading
"Manage Emerging Groups"
"Press the index (like \"1\") to select the group
Press again to set the value for the group"))
["Active groups:"
,@(if dirvish-emerge-groups
(dirvish-emerge--create-infixes)
(list '("+" " Press + to add a group"
(lambda () (interactive) (dirvish-emerge--ifx-add)))))]
["Actions:"
("RET" "Apply current setup" (lambda () (interactive) (dirvish-emerge--ifx-apply)))
("u" " Unselect all groups"
(lambda () (interactive) (dirvish-emerge--ifx-unselect)) :transient t)
("v" " Toggle visibility of selected"
(lambda () (interactive) (dirvish-emerge--ifx-toggle-hiding)) :transient t)
("a" " Add a group"
(lambda () (interactive) (dirvish-emerge--ifx-add)))
("x" " Remove selected groups"
(lambda () (interactive) (dirvish-emerge--ifx-remove)))
("t" " Promote selected groups (top)"
(lambda () (interactive) (dirvish-emerge--ifx-promote)))
("b" " Demote selected groups (bottom)"
(lambda () (interactive) (dirvish-emerge--ifx-promote 'demote)))
("n" " Jump to next group" dirvish-emerge-next-group
:transient t :if (lambda () dirvish-emerge--group-overlays))
("p" " Jump to previous group" dirvish-emerge-previous-group
:transient t :if (lambda () dirvish-emerge--group-overlays))
("r" " Read groups from .dir-locals.el"
(lambda () (interactive) (dirvish-emerge--ifx-read)))
("w" " Write groups to .dir-locals.el"
(lambda () (interactive) (dirvish-emerge--ifx-write)))]]))
(dirvish-emerge--menu))
;;;###autoload
(define-minor-mode dirvish-emerge-mode
"Toggle grouping of files in Dirvish."
:group 'dirvish
(if dirvish-emerge-mode
(progn
(add-hook 'dirvish-setup-hook #'dirvish-emerge--apply nil t)
(unless dirvish-emerge--group-overlays (dirvish-emerge--apply)))
(remove-hook 'dirvish-setup-hook #'dirvish-emerge--apply t)
(mapc #'delete-overlay dirvish-emerge--group-overlays)
(setq dirvish-emerge--group-overlays nil)
(revert-buffer)))
(defun dirvish-emerge--get-group-overlay ()
"Return overlay for the group at point."
(unless dirvish-emerge--group-overlays
(user-error "Dirvish: no groups applied here"))
(let ((pos (point)))
(cl-find-if (lambda (o) (and (overlay-start o)
(< pos (overlay-end o))
(>= pos (overlay-start o))))
dirvish-emerge--group-overlays)))
(defun dirvish-emerge-next-group (arg)
"Jump to the first file in the next ARG visible group."
(interactive "^p")
(let* ((old-ov (dirvish-emerge--get-group-overlay))
(old-idx (cl-position old-ov dirvish-emerge--group-overlays))
(target (+ old-idx arg))
(len (1- (length dirvish-emerge--group-overlays)))
(idx (max (min len target) 0))
(target-ov (nth idx dirvish-emerge--group-overlays)))
(while (and (not (or (>= idx len) (<= idx 0)))
(not (overlay-start target-ov)))
(setq idx (max (min len (+ idx (if (> arg 0) 1 -1))) 0))
(setq target-ov (nth idx dirvish-emerge--group-overlays)))
(cond ((eq old-idx idx))
((and target-ov (overlay-start target-ov))
(goto-char (overlay-start target-ov))))))
(defun dirvish-emerge-previous-group (arg)
"Jump to the first file in the previous ARG visible group."
(interactive "^p")
(dirvish-emerge-next-group (- 0 arg)))
(defun dirvish-emerge-toggle-current-group ()
"Toggle the current group."
(interactive)
(cl-loop
with curr-ov = (dirvish-emerge--get-group-overlay)
with groups = ()
with pos = (if (dirvish-prop :index) (overlay-start curr-ov) (point))
for o in dirvish-emerge--group-overlays
for (idx desc hide files) = (overlay-get o 'dirvish-emerge)
do (when (eq curr-ov o)
(setq hide (not hide))
(let ((group (nth idx dirvish-emerge-groups)))
(if (< (length group) 3)
(cl-callf append group '(t))
(cl-callf not (nth 2 group))))
(when hide
(setq files (buffer-substring
(save-excursion (goto-char (overlay-start o))
(forward-line 1) (point))
(overlay-end o)))))
do (push (list idx desc hide files) groups)
finally (dirvish-emerge--insert-groups (nreverse groups) pos)))
(provide 'dirvish-emerge)
;;; dirvish-emerge.el ends here