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 "*".

1 files changed, 78 insertions, 0 deletions

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