bug#70150: Better groups for Buffer-menu-group-by

[Juri Linkov <juri@linkov.net>]

[-- Attachment #1: Type: text/plain, Size: 429 bytes --]

> Here is a better grouping for Buffer-menu-group-by-mode
> that uses the existing mode categorization in
> mouse-buffer-menu-mode-groups.

This is the final patch that finishes the remaining features:

1. allows multi-level outlines
2. allows an entry to be in multiple groups
3. allows sorting of groups

Here is an example where on the first level of outlines there
are project names, and on the second level are mode names:


[-- Attachment #2: list-buffers-groups.png --]
[-- Type: image/png, Size: 60093 bytes --]

[-- Attachment #3: Type: text/plain, Size: 1050 bytes --]


Here is the definition that creates such multi-level outlines:

(setq tabulated-list-groups
      (tabulated-list-groups
       tabulated-list-entries
       '((path-fun . (lambda (b)
                       (list (list
                              ;; Project names
                              (with-current-buffer (car b)
                                (if-let ((project (project-current)))
                                    (project-name project)
                                  default-directory))
                              ;; Mode names
                              (let ((mode (aref (cadr b) 5)))
                                (or (cdr (seq-find (lambda (group)
                                                     (string-match-p (car group) mode))
                                                   mouse-buffer-menu-mode-groups))
                                    mode))))))
         (sort-fun . (lambda (groups)
                       ;; Sort groups by name
                       (sort groups :key #'car :in-place t))))))


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: tabulated-list-groups.patch --]
[-- Type: text/x-diff, Size: 3806 bytes --]

diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index c86e3f9c5df..d323d9e48a0 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -880,6 +880,84 @@ tabulated-list-mode
 
 (put 'tabulated-list-mode 'mode-class 'special)
 
+;;; Tabulated list groups
+
+(defun tabulated-list-groups (entries meta)
+  "Make a flat list of groups from list of ENTRIES.
+Return the data structure suitable to be set to the variable
+`tabulated-list-groups'.  META is an alist with two keys:
+PATH-FUN is a function to put an entry from ENTRIES to the tree
+\(see `tabulated-list-groups-treefy' for more information);
+SORT-FUN is a function to sort groups in the tree
+\(see `tabulated-list-groups-sort' for more information)."
+  (let* ((path-fun (alist-get 'path-fun meta))
+         (sort-fun (alist-get 'sort-fun meta))
+         (tree (tabulated-list-groups-treefy entries path-fun)))
+    (when sort-fun
+      (setq tree (tabulated-list-groups-sort tree sort-fun)))
+    (tabulated-list-groups-flatten tree)))
+
+(defun tabulated-list-groups-treefy (entries path-fun)
+  "Make a tree of groups from list of ENTRIES.
+On each entry from ENTRIES apply PATH-FUN 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-fun 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-fun)
+  "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-fun))))
+          (funcall sort-fun 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