From 7ced8e31112166df1d237d6e88448904ab87ac48 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 5 Jun 2024 20:07:28 +0300 Subject: [PATCH] Allow multi-level outlines in tabulated-list-groups used by list-buffers * lisp/emacs-lisp/tabulated-list.el (tabulated-list-groups) (tabulated-list-groups-categorize, tabulated-list-groups-sort) (tabulated-list-groups-flatten): New functions (bug#70150). * lisp/buff-menu.el (Buffer-menu-group-by): Change type from a function to a list of functions. (list-buffers--refresh): Use the function 'tabulated-list-groups' where :path-function uses a list of functions from 'Buffer-menu-group-by', and :sort-function is hard-coded to sort groups by name. (Buffer-menu-group-by-mode, Buffer-menu-group-by-root): Remove prefix "*". (cherry picked from commit ec8c0b0d0d8a6b8804fa3e6619242ec6db32fd19) --- lisp/buff-menu.el | 49 +++++++++++-------- lisp/emacs-lisp/tabulated-list.el | 78 +++++++++++++++++++++++++++++++ 2 files changed, 108 insertions(+), 19 deletions(-) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index d59c5b6cf21..d83bf2249e6 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -96,8 +96,10 @@ as it is by default." :version "22.1") (defcustom Buffer-menu-group-by nil - "If non-nil, a function to call to divide buffer-menu buffers into groups. -This function is called with one argument: a list of entries in the same + "If non-nil, functions to call to divide buffer-menu buffers into groups. +When customized to a list of functions, then each function defines +the group name at each nested level of multiple levels. +Each function is called with one argument: a list of entries in the same format as in `tabulated-list-entries', and should return a list in the format suitable for `tabulated-list-groups'. Also, when this variable is non-nil, `outline-minor-mode' is enabled in the Buffer Menu and you @@ -107,11 +109,13 @@ The default options can group by a mode, and by a root directory of a project or just `default-directory'. If this is nil, buffers are not divided into groups." :type '(choice (const :tag "No grouping" nil) - (const :tag "Group by mode" - Buffer-menu-group-by-mode) - (const :tag "Group by project root or directory" - Buffer-menu-group-by-root) - (function :tag "Custom function")) + (repeat :tag "Group by" + (choice + (const :tag "Group by project root or directory" + Buffer-menu-group-by-root) + (const :tag "Group by mode" + Buffer-menu-group-by-mode) + (function :tag "Custom function")))) :group 'Buffer-menu :version "30.1") @@ -775,10 +779,17 @@ See more at `Buffer-menu-filter-predicate'." '("File" 1 t))) (setq tabulated-list-use-header-line Buffer-menu-use-header-line) (setq tabulated-list-entries (nreverse entries)) - (when Buffer-menu-group-by - (setq tabulated-list-groups - (seq-group-by Buffer-menu-group-by - tabulated-list-entries)))) + (setq tabulated-list-groups + (tabulated-list-groups + tabulated-list-entries + `(:path-function + ,(lambda (entry) + (list (mapcar (lambda (f) (funcall f entry)) + Buffer-menu-group-by))) + :sort-function + ,(lambda (groups) + ;; Sort groups by name + (sort groups :key #'car :in-place t)))))) (tabulated-list-init-header)) (defun tabulated-list-entry-size-> (entry1 entry2) @@ -799,16 +810,16 @@ See more at `Buffer-menu-filter-predicate'." (defun Buffer-menu-group-by-mode (entry) (let ((mode (aref (cadr entry) 5))) - (concat "* " (or (cdr (seq-find (lambda (group) - (string-match-p (car group) mode)) - mouse-buffer-menu-mode-groups)) - mode)))) + (or (cdr (seq-find (lambda (group) + (string-match-p (car group) mode)) + mouse-buffer-menu-mode-groups)) + mode))) (declare-function project-root "project" (project)) (defun Buffer-menu-group-by-root (entry) - (concat "* " (with-current-buffer (car entry) - (if-let ((project (project-current))) - (project-root project) - default-directory)))) + (with-current-buffer (car entry) + (if-let ((project (project-current))) + (project-root project) + default-directory))) ;;; buff-menu.el ends here diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index c86e3f9c5df..a0a58bf8b42 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -880,6 +880,84 @@ as the ewoc pretty-printer." (put 'tabulated-list-mode 'mode-class 'special) +;;; Tabulated list groups + +(defun tabulated-list-groups (entries metadata) + "Make a flat list of groups from list of ENTRIES. +Return the data structure suitable to be set to the variable +`tabulated-list-groups'. METADATA is a property list with two keys: +PATH-FUNCTION is a function to put an entry from ENTRIES to the tree +\(see `tabulated-list-groups-categorize' for more information); +SORT-FUNCTION is a function to sort groups in the tree +\(see `tabulated-list-groups-sort' for more information)." + (let* ((path-function (plist-get metadata :path-function)) + (sort-function (plist-get metadata :sort-function)) + (tree (tabulated-list-groups-categorize entries path-function))) + (when sort-function + (setq tree (tabulated-list-groups-sort tree sort-function))) + (tabulated-list-groups-flatten tree))) + +(defun tabulated-list-groups-categorize (entries path-function) + "Make a tree of groups from list of ENTRIES. +On each entry from ENTRIES apply PATH-FUNCTION that should return a list of +paths that the entry has on the group tree that means that every entry +can belong to multiple categories. Every path is a list of strings +where every string is an outline heading at increasing level of deepness." + (let ((tree nil) + (hash (make-hash-table :test #'equal))) + (cl-labels + ((trie-add (list tree) + (when list + (setf (alist-get (car list) tree nil nil #'equal) + (trie-add (cdr list) + (alist-get (car list) tree nil nil #'equal))) + tree)) + (trie-get (tree path) + (mapcar (lambda (elt) + (cons (car elt) + (if (cdr elt) + (trie-get (cdr elt) (cons (car elt) path)) + (apply #'vector (nreverse + (gethash (reverse + (cons (car elt) path)) + hash)))))) + (reverse tree)))) + (dolist (entry entries) + (dolist (path (funcall path-function entry)) + (unless (gethash path hash) + (setq tree (trie-add path tree))) + (cl-pushnew entry (gethash path hash)))) + (trie-get tree nil)))) + +(defun tabulated-list-groups-sort (tree sort-function) + "Sort TREE using the sort function SORT-FUN." + (mapcar (lambda (elt) + (if (vectorp (cdr elt)) + elt + (cons (car elt) (tabulated-list-groups-sort + (cdr elt) sort-function)))) + (funcall sort-function tree))) + +(defun tabulated-list-groups-flatten (tree) + "Flatten multi-level TREE to single level." + (let ((header "") acc) + (cl-labels + ((flatten (tree level) + (mapcar (lambda (elt) + (setq header (format "%s%s %s\n" header + (make-string level ?*) + (car elt))) + (cond + ((vectorp (cdr elt)) + (setq acc (cons (cons (string-trim-right header) + (append (cdr elt) nil)) + acc)) + (setq header "")) + (t (flatten (cdr elt) (1+ level))))) + tree))) + (flatten tree 1) + (nreverse acc)))) + (provide 'tabulated-list) ;;; tabulated-list.el ends here -- 2.39.5