branch: externals/org
commit 23d219693ccf0e185bacaf00f8a7d9e609e635b8
Author: Morgan Smith <morgan.j.sm...@outlook.com>
Commit: Ihor Radchenko <yanta...@posteo.net>

    lisp/org.el: Add ability to sort tags by hierarchy
    
    * lisp/org.el (org-tags-sort-hierarchy): New function.
    (org-tags-sort-function): Add new function to type and docstring.
    * etc/ORG-NEWS: Announce the new feature.
    * testing/lisp/test-org-agenda.el (test-org-agenda/tags-sorting): Test
    sorting with a value of 'org-tags-sort-hierarchy.
---
 etc/ORG-NEWS                    |  7 +++++++
 lisp/org.el                     | 43 ++++++++++++++++++++++++++++++++++++++++-
 testing/lisp/test-org-agenda.el | 31 +++++++++++++++++++++++++++--
 3 files changed, 78 insertions(+), 3 deletions(-)

diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index a7763ef517..08d2bd9381 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -364,6 +364,13 @@ properties.
 Subsequent sorting functions will be used if two tags are found to be
 equivalent.  See docstring for more information.
 
+*** New tags sorting function ~org-tags-sort-hierarchy~
+
+By setting ~org-tags-sort-function~ to ~org-tags-sort-hierarchy~, tags
+are sorted taking their hierarchy into account.  See
+[[info:org#Tag Hierarchy][Tag Hierarchy]] for how to set up a tag
+hierarchy.
+
 *** New option ~org-cite-basic-complete-key-crm-separator~
 
 This option makes ~org-cite~'s ~basic~ insert processor use
diff --git a/lisp/org.el b/lisp/org.el
index 178611f8e8..65abfbe1a3 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -3019,12 +3019,16 @@ that both tags are deemed equal and they will then be 
sorted by the next
 sort function in the list.
 
 A sort function can call `org-tag-sort' which will use the next sort
-function in the list."
+function in the list.
+
+For an example of a function that uses this advanced sorting system, see
+`org-tags-sort-hierarchy'."
   :group 'org-tags
   :type '(choice
          (const :tag "Default sorting" nil)
          (const :tag "Alphabetical" org-string<)
          (const :tag "Reverse alphabetical" org-string>)
+          (const :tag "Sort by hierarchy" org-tags-sort-hierarchy)
           (function :tag "Custom function" nil)
           (repeat function)))
 
@@ -4373,6 +4377,43 @@ See `org-tag-alist' for their structure."
            (t ; tag1 = tag2
             'continue-loop)))))))
 
+(defun org-tags-sort-hierarchy (tag1 tag2)
+  "Sort tags TAG1 and TAG2 by the tag hierarchy.
+
+See Info node `(org) Tag Hierarchy' or `org-tag-alist' for how to set up
+a tag hierarchy.
+
+This function is intended to be a value of `org-tags-sort-function'."
+  (let ((group-alist (or org-tag-groups-alist-for-agenda
+                         org-tag-groups-alist)))
+    (if (not (and org-group-tags
+                  group-alist))
+        (org-tags-sort 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 (and
+                          ;; Prevent infinite loop
+                          (not (member tag (cdr result)))
+                          (setq tag
+                                (map-some
+                                 (lambda (key tags)
+                                   (when (member tag tags)
+                                     key))
+                                 group-alist)))
+                    (push tag result))
+                  result)))
+             (tag1-path (funcall tag-path-function tag1))
+             (tag2-path (funcall tag-path-function tag2)))
+        (catch :result
+          (dotimes (n (min (length tag1-path) (length tag2-path)))
+            ;; find the first difference and sort on that
+            (unless (string-equal (nth n tag1-path) (nth n tag2-path))
+              (throw :result (org-tags-sort (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-agenda.el b/testing/lisp/test-org-agenda.el
index 3c2102905e..e59461bdb4 100644
--- a/testing/lisp/test-org-agenda.el
+++ b/testing/lisp/test-org-agenda.el
@@ -665,7 +665,24 @@ Sunday      7 January 2024
              (org-agenda-overriding-header "")
              (org-agenda-prefix-format "")
              (org-agenda-remove-tags t)
-             (org-agenda-sorting-strategy '(tag-up)))))))
+             (org-agenda-sorting-strategy '(tag-up))))))
+        (org-tag-alist
+         ;; Tag "blueberry" is intentionally not in this variable but
+         ;; used in testing
+         '((:startgrouptag)
+           ("group_a")
+           (:grouptags)
+           ("tag_a_1")
+           ("tag_a_2")
+           ("group_a") ;; try to create infinite loop
+           (:endgrouptag)
+           (:startgroup)
+           ("tag_b_1")
+           ("tag_b_1") ;; duplicated
+           ("tag_b_2")
+           (:endgroup)
+           ("groupless")
+           ("lonely"))))
     (org-test-agenda-with-agenda
      (string-join
       '("* TODO group_a :group_a:"
@@ -681,7 +698,9 @@ Sunday      7 January 2024
                                        org-string< org-string> ignore
                                        ,string-length<
                                        (,string-length<)
-                                       (,string-length< org-string<)))
+                                       (,string-length< org-string<)
+                                       org-tags-sort-hierarchy
+                                       (org-tags-sort-hierarchy org-string>)))
        (should
         (string-equal
          (string-trim
@@ -710,6 +729,14 @@ Sunday      7 January 2024
            (`(,string-length< org-string<)
             (string-join
              '("lonely" "group_a" "tag_a_1" "tag_a_2" "tag_b_1" "tag_b_2" 
"blueberry" "groupless")
+             "\n"))
+           ('org-tags-sort-hierarchy
+            (string-join
+             '("blueberry" "group_a" "tag_a_1" "tag_a_2" "groupless" "lonely" 
"tag_b_1" "tag_b_2")
+             "\n"))
+           ('(org-tags-sort-hierarchy org-string>)
+            (string-join
+             '("tag_b_2" "tag_b_1" "lonely" "groupless" "group_a" "tag_a_2" 
"tag_a_1" "blueberry")
              "\n")))))))))
 
 (ert-deftest test-org-agenda/goto-date ()

Reply via email to