Ihor Radchenko <yanta...@posteo.net> writes:
>
> Hmm. I think we can do it differently.
> Rather than trying to do secondary sorting in
> `org-tags-sort-hierarchy...' we can allow `org-tags-sort-function' to be
> a list of functions. Then, when sorting, if (sort-function a b) and
> (sort-function b a) return the same value (which means that a=b wrt a
> given sort-function), we try second sort function in the list, and so
> on.
>
> It will be (1) more universal; (2) follow our existing practice in
> `org-agenda-sorting-strategy'.
>
> WDYT?
Unless I am mistaken, performing the secondary sorting in the function is
mandatory. I have included my reasoning below.
However, I believe I have managed to come up with a flexible solution that does
involve allowing `org-tags-sort-function' to be a list of functions. The trick
is to lexically bind the list each time so we don't get infinite recursion.
Attached are two patches
* I don't believe we can remove secondary sorting from the comparison function
Just because a=b does not mean that they should end up beside each other.
Imagine a hierarchy like this:
A
| \
B D
|
F
So if we have B and F, we know B should be before F.
Now lets sort the list (B D F).
B and D don't have a hierarchy sorting so they fall back to alphabetical
secondary sorting.
The sorted list now looks like (B D).
We now compare D to F and again fall back to alphabetical sorting so the sorted
list looks like (B D F).
The type of sorting I'm trying to do would have the list end up as (B F D)
since F falls under B.
>From 7951ff4639197cd846e292bf30c731846e05c3f2 Mon Sep 17 00:00:00 2001
From: Morgan Smith <morgan.j.sm...@outlook.com>
Date: Tue, 27 May 2025 15:14:34 -0400
Subject: [PATCH 1/2] Allow `org-tags-sort-function' to be a list of functions
* lisp/org.el (org-tags-sort-function): Add '(repeat function) to the
type.
(org-tags-sort): New function
* lisp/org-agenda.el (org-cmp-tag): Use `org-tags-sort'.
* lisp/org-mouse.el (org-mouse-tag-menu, org-mouse-popup-global-menu):
Use `org-tags-sort'.
* testing/lisp/test-org.el (test-org/toggle-tag): Fix tag order.
* etc/ORG-NEWS: Announce the new feature.
---
etc/ORG-NEWS | 6 ++++++
lisp/org-agenda.el | 4 ++--
lisp/org-mouse.el | 8 ++++----
lisp/org.el | 22 +++++++++++++++++++---
testing/lisp/test-org.el | 2 +-
5 files changed, 32 insertions(+), 10 deletions(-)
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 62502a678..770abca2c 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -349,6 +349,12 @@ behaviour of other exporters. In this case, to exclude a section from
the table of contents, mark it as =:UNNUMBERED: notoc= in its
properties.
+*** ~org-tags-sort-function~ can now be a list of functions
+
+~org-tags-sort-function~ can now be set to a list of functions. This
+allows sorting functions to call ~org-tags-sort~ recursively if they
+find two tags to be equivalent.
+
*** New option ~org-cite-basic-complete-key-crm-separator~
This option makes ~org-cite~'s ~basic~ insert processor use
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 7f0a6ee75..a10ae1888 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -7570,8 +7570,8 @@ The optional argument TYPE tells the agenda type."
(cond ((not (or ta tb)) nil)
((not ta) +1)
((not tb) -1)
- ((funcall (or org-tags-sort-function #'org-string<) ta tb) -1)
- ((funcall (or org-tags-sort-function #'org-string<) tb ta) +1))))
+ ((org-tags-sort ta tb) -1)
+ ((org-tags-sort tb ta) +1))))
(defsubst org-cmp-time (a b)
"Compare the time-of-day values of strings A and B."
diff --git a/lisp/org-mouse.el b/lisp/org-mouse.el
index a282f004c..bc0857d3c 100644
--- a/lisp/org-mouse.el
+++ b/lisp/org-mouse.el
@@ -427,13 +427,13 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(let ((tags (org-get-tags nil t)))
(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags))
- (or org-tags-sort-function #'org-string<))
+ #'org-tags-sort)
(lambda (tag)
(org-mouse-set-tags
(sort (if (member tag tags)
(delete tag tags)
(cons tag tags))
- (or org-tags-sort-function #'org-string<))))
+ #'org-tags-sort)))
(lambda (tag) (member tag tags))
))
'("--"
@@ -504,7 +504,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
("Check Tags"
,@(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags))
- (or org-tags-sort-function #'org-string<))
+ #'org-tags-sort)
(lambda (tag) (org-tags-sparse-tree nil tag)))
"--"
["Custom Tag ..." org-tags-sparse-tree t])
@@ -515,7 +515,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
("Display Tags"
,@(org-mouse-keyword-menu
(sort (mapcar #'car (org-get-buffer-tags))
- (or org-tags-sort-function #'org-string<))
+ #'org-tags-sort)
(lambda (tag) (org-tags-view nil tag)))
"--"
["Custom Tag ..." org-tags-view t])
diff --git a/lisp/org.el b/lisp/org.el
index 174c4c8e5..57ed597c4 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -3015,7 +3015,8 @@ default."
(const :tag "Default sorting" nil)
(const :tag "Alphabetical" org-string<)
(const :tag "Reverse alphabetical" org-string>)
- (function :tag "Custom function" nil)))
+ (function :tag "Custom function" nil)
+ (repeat function)))
(defvar org-tags-history nil
"History of minibuffer reads for tags.")
@@ -4333,6 +4334,22 @@ See `org-tag-alist' for their structure."
;; Preserve order of ALIST1.
(append (nreverse to-add) alist2)))))
+(defun org-tags-sort (tag1 tag2)
+ "Sort tags TAG1 and TAG2 according to the value of `org-tags-sort-function'."
+ (cond
+ ((functionp org-tags-sort-function)
+ (let ((sort-fun org-tags-sort-function)
+ ;; So the function can call `org-tags-sort'
+ (org-tags-sort-function nil))
+ (funcall sort-fun tag1 tag2)))
+ ((consp org-tags-sort-function)
+ (let* ((sort-fun (car org-tags-sort-function))
+ ;; So the functions can call `org-tags-sort'
+ (org-tags-sort-function (cdr org-tags-sort-function)))
+ (funcall sort-fun tag1 tag2)))
+ ((null org-tags-sort-function)
+ (org-string< tag1 tag2))))
+
(defun org-priority-to-value (s)
"Convert priority string S to its numeric value."
(or (save-match-data
@@ -12114,8 +12131,7 @@ This function assumes point is on a headline."
(_ (error "Invalid tag specification: %S" tags))))
(old-tags (org-get-tags nil t))
(tags-change? nil))
- (when (functionp org-tags-sort-function)
- (setq tags (sort tags org-tags-sort-function)))
+ (setq tags (sort tags #'org-tags-sort))
(setq tags-change? (not (equal tags old-tags)))
(when tags-change?
;; Delete previous tags and any trailing white space.
diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el
index 79102d382..50d8ec6ad 100644
--- a/testing/lisp/test-org.el
+++ b/testing/lisp/test-org.el
@@ -8469,7 +8469,7 @@ Paragraph<point>"
;; Special case: Handle properly tag inheritance. In particular, do
;; not set inherited tags.
(should
- (equal "* H1 :tag:\n** H2 :tag2:tag:"
+ (equal "* H1 :tag:\n** H2 :tag:tag2:"
(org-test-with-temp-text "* H1 :tag:\n** <point>H2 :tag2:"
(let ((org-use-tag-inheritance t)
(org-tags-column 1))
--
2.49.0
>From 53096a5b124e7e80066215cccfeaea29546c3ea8 Mon Sep 17 00:00:00 2001
From: Morgan Smith <morgan.j.sm...@outlook.com>
Date: Fri, 14 Jun 2024 17:38:41 -0400
Subject: [PATCH 2/2] 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.
* 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 | 6 ++++++
lisp/org.el | 37 +++++++++++++++++++++++++++++++++
testing/lisp/test-org-agenda.el | 37 +++++++++++++++++++++++++++------
3 files changed, 74 insertions(+), 6 deletions(-)
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 770abca2c..72010daaa 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -355,6 +355,12 @@ properties.
allows sorting functions to call ~org-tags-sort~ recursively if they
find two tags to be equivalent.
+*** 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 ~org-tag-alist~
+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 57ed597c4..9bcb7fb67 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -3015,6 +3015,7 @@ default."
(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)))
@@ -4350,6 +4351,42 @@ See `org-tag-alist' for their structure."
((null org-tags-sort-function)
(org-string< tag1 tag2))))
+(defun org-tags-sort-hierarchy (tag1 tag2)
+ "Sort tags TAG1 and TAG2 by the tag hierarchy.
+See `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 (setq tag
+ (map-some
+ (lambda (key tags)
+ (when (and (member tag tags)
+ ;; Prevent infinite loop
+ (not (member tag (cdr result))))
+ 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 and does not allow us to use
+ ;; `org-tags-sort-function'.
+ ;; (value< tag1-path tag2-path)
+ (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 06d5abc43..140e34d1e 100644
--- a/testing/lisp/test-org-agenda.el
+++ b/testing/lisp/test-org-agenda.el
@@ -663,18 +663,35 @@ 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
+ '((: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:"
- "* TODO tag_a_1 :tag_a_1:"
+ "* TODO groupless :groupless:"
"* TODO tag_a_2 :tag_a_2:"
- "* TODO tag_b_1 :tag_b_1:"
"* TODO tag_b_2 :tag_b_2:"
- "* TODO groupless :groupless:"
+ "* TODO tag_a_1 :tag_a_1:"
+ "* TODO tag_b_1 :tag_b_1:"
"* TODO lonely :lonely:")
"\n")
- (dolist (org-tags-sort-function '(nil org-string< org-string> ignore))
+ (dolist (org-tags-sort-function '(nil org-string< org-string>
+ ignore org-tags-sort-hierarchy
+ (org-tags-sort-hierarchy org-string>)))
(should
(string-equal
(string-trim
@@ -685,7 +702,7 @@ Sunday 7 January 2024
;; Not sorted
('ignore
(string-join
- '("group_a" "tag_a_1" "tag_a_2" "tag_b_1" "tag_b_2" "groupless" "lonely")
+ '("group_a" "groupless" "tag_a_2" "tag_b_2" "tag_a_1" "tag_b_1" "lonely")
"\n"))
((or 'nil 'org-string<)
(string-join
@@ -694,6 +711,14 @@ Sunday 7 January 2024
('org-string>
(string-join
'("tag_b_2" "tag_b_1" "tag_a_2" "tag_a_1" "lonely" "groupless" "group_a")
+ "\n"))
+ ('org-tags-sort-hierarchy
+ (string-join
+ '("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")
"\n")))))))))
(ert-deftest test-org-agenda/goto-date ()
--
2.49.0
