branch: externals/org
commit b02c34948b051f8714c682f22f9a9cfc91c0501e
Author: Morgan Smith <morgan.j.sm...@outlook.com>
Commit: Ihor Radchenko <yanta...@posteo.net>
Allow `org-tags-sort-function' to be a list of functions
* lisp/org.el (org-tags-sort-function): Describe new feature. 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-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 | 38 ++++++++++++++++++++++++++++++++++----
testing/lisp/test-org-agenda.el | 32 ++++++++++++++++++++++++--------
5 files changed, 70 insertions(+), 18 deletions(-)
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index 375a0c4241..a7763ef517 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -358,6 +358,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. See docstring for more information.
+
*** 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 7f0a6ee759..a10ae18884 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 a282f004c7..bc0857d3c3 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 a98adf927c..178611f8e8 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -3009,13 +3009,24 @@ is better to limit inheritance to certain tags using
the variables
"When set, tags are sorted using this function as a comparator.
When the value is nil, use default sorting order. The default sorting
is alphabetical, except in `org-set-tags' where no sorting is done by
-default."
+default.
+
+This can also be a list of functions. To enable advanced sorting
+algorithms a special algorithm is used. If a sorting function returns
+nil when comparing two tags, then it is tried again with the tags in the
+opposite order. If the function once again returns nil, it is assumed
+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."
:group 'org-tags
:type '(choice
(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.")
@@ -4343,6 +4354,25 @@ 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'."
+ (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)
+ ;; Default sorting as described in docstring of
`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
@@ -12123,8 +12153,8 @@ 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)))
+ (when 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 06d5abc43a..3c2102905e 100644
--- a/testing/lisp/test-org-agenda.el
+++ b/testing/lisp/test-org-agenda.el
@@ -657,7 +657,9 @@ Sunday 7 January 2024
(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 @@ Sunday 7 January 2024
(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 @@ 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" "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 ()
