Ihor Radchenko <yanta...@posteo.net> writes:
> Morgan Smith <morgan.j.sm...@outlook.com> writes:
>
>> 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.
>> ...
>> +(defun org-tags-sort (tag1 tag2)
>> + "Sort tags TAG1 and TAG2 according to the value of
>> `org-tags-sort-function'."
>> + (cond
>> ...
>> + ((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)))
>
> This implies that every possible sort function will take care about
> calling `org-tags-sort' recursively. I do not think that it is a good
> idea. Consider (setq org-tags-sort-function '(length<
> org-tags-sort-hierarchy)).
> There is no way `length<' know to call `org-tags-sort'! So,
> `org-tags-sort-hierarchy' in the list will always be ignored. Not
> expected, IMHO.
Thank you for bring this case to my attention in such a concrete way. I
have added fixes and tests to make this work.
>
> Instead, we can do the following:
>
> (catch :org-tags-sort-return ; also allow individual sort functions to exit
> early
> (dolist (sort-fun org-tags-sort-function)
> (cond
> ((funcall sort-fun tag1 tag2) ; tag1 < tag2
> (throw :org-tags-sort-return t))
> ((funcall sort-fun tag2 tag1) ; tag1 > tag2
> (throw :org-tags-sort-return nil))
> (t ; tag1 = tag2
> 'continue-loop)))
> ;; tag1 = tag2 for each function in the list
> nil)
>
> Then, if you need to perform custom sorting, you can return early from
> `org-tags-sort-hierarchy':
>
> (let ((org-tags-sort-function (delete #'org-tags-sort-hierarchy
> org-tags-sort-function)))
> (throw :org-tags-sort-return (org-tags-sort (nth n tag1-path) (nth n
> tag2-path)))
>
> WDYT?
I'm not a fan of non-local exits while re-binding variable values. Also
the `delete' and `throw' would cause errors in the case that
'org-tags-sort-function' is a function, not a list.
After adding your suggested changes and playing around with things I
think I have come up with a very nice solution. Please see attached.
>From 4369436b05214486d9f7c29fdbc87aed991f18da 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.
* testing/lisp/test-org-agenda.el (test-org-agenda/tags-sorting): Test
new functionality.
* etc/ORG-NEWS: Announce the new feature.
---
etc/ORG-NEWS | 6 ++++++
lisp/org-agenda.el | 4 ++--
lisp/org-mouse.el | 8 ++++----
lisp/org.el | 24 +++++++++++++++++++++---
testing/lisp/test-org-agenda.el | 32 ++++++++++++++++++++++++--------
testing/lisp/test-org.el | 2 +-
6 files changed, 58 insertions(+), 18 deletions(-)
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 62502a678..810a0b02b 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.
+Subsequent sorting functions will be used if two tags are found 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 @@ org-cmp-tag
(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 @@ org-mouse-tag-menu
(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 @@ org-mouse-popup-global-menu
("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 @@ org-mouse-popup-global-menu
("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 0a406d7cc..37baf171e 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -3015,7 +3015,8 @@ org-tags-sort-function
(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,24 @@ org--tag-add-to-alist
;; 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'."
+ (let ((org-tags-sort-function
+ (cond ((functionp org-tags-sort-function) (list org-tags-sort-function))
+ ((consp org-tags-sort-function) org-tags-sort-function)
+ ((null org-tags-sort-function) (list #'org-string<)))))
+ (catch :org-tags-sort-return
+ (dolist (sort-fun org-tags-sort-function)
+ ;; So the function can call `org-tags-sort'
+ (let ((org-tags-sort-function (cdr org-tags-sort-function)))
+ (cond
+ ((funcall sort-fun tag1 tag2) ; tag1 < tag2
+ (throw :org-tags-sort-return t))
+ ((funcall sort-fun tag2 tag1) ; tag1 > tag2
+ (throw :org-tags-sort-return nil))
+ (t ; tag1 = tag2
+ 'continue-loop)))))))
+
(defun org-priority-to-value (s)
"Convert priority string S to its numeric value."
(or (save-match-data
@@ -12114,8 +12133,7 @@ org-set-tags
(_ (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-agenda.el b/testing/lisp/test-org-agenda.el
index 06d5abc43..3c2102905 100644
--- a/testing/lisp/test-org-agenda.el
+++ b/testing/lisp/test-org-agenda.el
@@ -657,7 +657,9 @@ test-org-agenda/skip-scheduled-repeats-after-deadline
(ert-deftest test-org-agenda/tags-sorting ()
"Test if `org-agenda' sorts tags according to `org-tags-sort-function'."
- (let ((org-agenda-custom-commands
+ (let ((string-length< (lambda (s1 s2)
+ (< (length s1) (length s2))))
+ (org-agenda-custom-commands
'(("f" "no fluff" todo ""
((org-agenda-todo-keyword-format "")
(org-agenda-overriding-header "")
@@ -667,14 +669,19 @@ test-org-agenda/tags-sorting
(org-test-agenda-with-agenda
(string-join
'("* TODO group_a :group_a:"
- "* TODO tag_a_1 :tag_a_1:"
"* 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 lonely :lonely:")
+ "* TODO tag_a_1 :tag_a_1:"
+ "* TODO tag_b_1 :tag_b_1:"
+ "* TODO lonely :lonely:"
+ "* TODO blueberry :blueberry:")
"\n")
- (dolist (org-tags-sort-function '(nil org-string< org-string> ignore))
+ (dolist (org-tags-sort-function `(nil
+ org-string< org-string> ignore
+ ,string-length<
+ (,string-length<)
+ (,string-length< org-string<)))
(should
(string-equal
(string-trim
@@ -685,15 +692,24 @@ test-org-agenda/tags-sorting
;; Not sorted
('ignore
(string-join
- '("group_a" "tag_a_1" "tag_a_2" "tag_b_1" "tag_b_2" "groupless" "lonely")
+ '("group_a" "tag_a_2" "tag_b_2" "groupless" "tag_a_1" "tag_b_1" "lonely" "blueberry")
"\n"))
((or 'nil 'org-string<)
(string-join
- '("group_a" "groupless" "lonely" "tag_a_1" "tag_a_2" "tag_b_1" "tag_b_2")
+ '("blueberry" "group_a" "groupless" "lonely" "tag_a_1" "tag_a_2" "tag_b_1" "tag_b_2")
"\n"))
('org-string>
(string-join
- '("tag_b_2" "tag_b_1" "tag_a_2" "tag_a_1" "lonely" "groupless" "group_a")
+ '("tag_b_2" "tag_b_1" "tag_a_2" "tag_a_1" "lonely" "groupless" "group_a" "blueberry")
+ "\n"))
+ ((or (pred (equal string-length<))
+ `(,string-length<))
+ (string-join
+ '("lonely" "group_a" "tag_a_2" "tag_b_2" "tag_a_1" "tag_b_1" "groupless" "blueberry")
+ "\n"))
+ (`(,string-length< org-string<)
+ (string-join
+ '("lonely" "group_a" "tag_a_1" "tag_a_2" "tag_b_1" "tag_b_2" "blueberry" "groupless")
"\n")))))))))
(ert-deftest test-org-agenda/goto-date ()
diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el
index 36dea35b7..40bd9d716 100644
--- a/testing/lisp/test-org.el
+++ b/testing/lisp/test-org.el
@@ -8484,7 +8484,7 @@ test-org/toggle-tag
;; 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 c4f6c30c4a60491d109c9d6abef0342c1f1cd941 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 | 29 ++++++++++++++++++++++++--
3 files changed, 70 insertions(+), 2 deletions(-)
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 810a0b02b..732868416 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -355,6 +355,12 @@ properties.
Subsequent sorting functions will be used if two tags are found 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 37baf171e..9430c5eeb 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -3015,6 +3015,7 @@ org-tags-sort-function
(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)))
@@ -4352,6 +4353,42 @@ org-tags-sort
(t ; tag1 = tag2
'continue-loop)))))))
+(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 3c2102905..617637f54 100644
--- a/testing/lisp/test-org-agenda.el
+++ b/testing/lisp/test-org-agenda.el
@@ -665,7 +665,22 @@ test-org-agenda/tags-sorting
(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:"
@@ -681,7 +696,9 @@ test-org-agenda/tags-sorting
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 +727,14 @@ test-org-agenda/tags-sorting
(`(,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 ()
--
2.49.0
