GNU bug report logs - #70150
Better groups for Buffer-menu-group-by

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 70150 in the body.
You can then email your comments to 70150 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Juri Linkov <juri <at> linkov.net>
To: bug-gnu-emacs <at> gnu.org
Subject: Better groups for Buffer-menu-group-by
Date: Tue, 02 Apr 2024 19:44:27 +0300

[Message part 1 (text/plain, inline)]

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

[Buffer-menu-group-by-mode.patch (text/x-diff, inline)]

diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index ec5337e3fda..1f7d40c5a14 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -798,7 +805,11 @@ Buffer-menu--pretty-file-name
 	(t "")))
 
 (defun Buffer-menu-group-by-mode (entry)
-  (concat "* " (aref (cadr entry) 5)))
+  (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))))
 
 (declare-function project-root "project" (project))
 (defun Buffer-menu-group-by-root (entry)

Message #8 received at 70150 <at> debbugs.gnu.org (full text, mbox):

From: Juri Linkov <juri <at> linkov.net>
To: 70150 <at> debbugs.gnu.org
Subject: Re: bug#70150: Better groups for Buffer-menu-group-by
Date: Wed, 05 Jun 2024 09:48:28 +0300

[Message part 1 (text/plain, inline)]

> 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:

[list-buffers-groups.png (image/png, inline)]

[Message part 3 (text/plain, inline)]

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))))))

[tabulated-list-groups.patch (text/x-diff, inline)]

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

Message #11 received at 70150 <at> debbugs.gnu.org (full text, mbox):

From: Juri Linkov <juri <at> linkov.net>
To: 70150 <at> debbugs.gnu.org
Subject: Re: bug#70150: Better groups for Buffer-menu-group-by
Date: Wed, 05 Jun 2024 20:08:06 +0300

close 70150 30.0.50
thanks

>> 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

Now pushed and closed.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.