[PATCH] lisp/org.el: Add ability to sort tags by hierarchy

[Morgan Smith <Morgan.J.Smith@outlook.com>]

* lisp/org.el (org-tags-sort-hierarchy): New function.
(org-tags-sort-function): Add new function to type.
* testing/lisp/test-org.el (test-org/tags-sort-hierarchy): New test
---

This is one of those things that I thought would be easy but then ended up
hard.

I wrote this so that items in my agenda would sort nicely.  Items tagged in the
same hierarchy would end up next to each other.

 lisp/org.el              | 38 +++++++++++++++++++++++++++++++++++++-
 testing/lisp/test-org.el | 19 +++++++++++++++++++
 2 files changed, 56 insertions(+), 1 deletion(-)

diff --git a/lisp/org.el b/lisp/org.el
index 750b060f3..b828f4127 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -2955,7 +2955,8 @@ is better to limit inheritance to certain tags using the variables
 	  (const :tag "No sorting" nil)
 	  (const :tag "Alphabetical" org-string<)
 	  (const :tag "Reverse alphabetical" org-string>)
-	  (function :tag "Custom function" nil)))
+          (const :tag "Hierarchy" org-tags-sort-hierarchy)
+          (function :tag "Custom function" nil)))
 
 (defvar org-tags-history nil
   "History of minibuffer reads for tags.")
@@ -4262,6 +4263,41 @@ See `org-tag-alist' for their structure."
       ;; Preserve order of ALIST1.
       (append (nreverse to-add) alist2)))))
 
+(defun org-tags-sort-hierarchy (tag1 tag2)
+  "Sort tags TAG1 and TAG2 by the tag hierarchy.
+Sorting is done alphabetically.  This function is intended to be a value
+of `org-tags-sort-function'."
+  (let ((sort-func #'org-string<)
+        (group-alist (or org-tag-groups-alist-for-agenda
+                         org-tag-groups-alist)))
+    (if (not (and org-group-tags
+                  group-alist))
+        (funcall sort-func tag1 tag2)
+      (let* ((tag-path-function
+              ;; Returns a list of tags describing the tag path
+              ;; ex: '("top level tag" "second level" "tag")
+              (lambda (tag)
+                (let ((result (list tag)))
+                  (while (setq tag
+                               (map-some
+                                (lambda (key tags)
+                                  (when (and (member tag tags)
+                                             ;; infinite loop (only catches the trivial case)
+                                             (not (string-equal tag key)))
+                                    key))
+                                group-alist))
+                    (push tag result))
+                  result)))
+             (tag1-path (funcall tag-path-function tag1))
+             (tag2-path (funcall tag-path-function tag2)))
+        ;; value< was added in Emacs 30
+        ;; (value< tag1-path tag2-path)
+        (catch :result
+          (dotimes (n (min (length tag1-path) (length tag2-path)))
+            (unless (string-equal (nth n tag1-path) (nth n tag2-path))
+              (throw :result (funcall sort-func (nth n tag1-path) (nth n tag2-path)))))
+          (< (length tag1-path) (length tag2-path)))))))
+
 (defun org-priority-to-value (s)
   "Convert priority string S to its numeric value."
   (or (save-match-data
diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el
index f21e52bfd..59b16a62a 100644
--- a/testing/lisp/test-org.el
+++ b/testing/lisp/test-org.el
@@ -8508,6 +8508,25 @@ Paragraph<point>"
 	    (org-mode-restart)
 	    (let ((org-tag-alist-for-agenda nil)) (org-tags-expand "{A+}"))))))
 
+(ert-deftest test-org/tags-sort-hierarchy ()
+  "Test `org-tags-sort-hierarchy' specifications."
+  (let ((org-tag-groups-alist-for-agenda
+         '(("A" "B" "D" "z" "zz")
+           ("B" "y")
+           ("C" "x")
+           ("D" "w")
+           ("E" "C" "v")))
+        (test-list '("v" "w" "x" "y" "zz" "z" "E" "D" "C" "B" "A")))
+    (should (equal
+             '("A" "B" "y" "D" "w" "z" "zz" "E" "C" "x" "v")
+             (sort test-list #'org-tags-sort-hierarchy))))
+  ;; infinite loop (tag "A" should not be in the "A" group)
+  (let ((org-tag-groups-alist-for-agenda
+         '(("A" "A" "B")))
+        (test-list '("B" "A")))
+    (should (equal
+             '("A" "B")
+             (sort test-list #'org-tags-sort-hierarchy)))))
 \f
 ;;; TODO keywords
 
-- 
2.45.1