[This is only lightly tested and therefore probably not quite ready for merging yet; however I'm submitting now to get feedback.]
org-entries-lessp was not as efficient a multi-criteria comparator as it could have been, since it evaluated all criteria and then combined them via (eval (cons 'or ...)), thereby missing a chance for lazy evaluation via short-circuiting: if one of the earlier criteria in org-agenda-sorting-strategy-selected evaluates to non-nil, giving a definitive comparison result, there is no need to evaluate any of the later criteria. So instead iterate over the criteria one by one, and return as soon as we have a definitive result. Also remove code duplication by adopting a unified approach to ascending/descending sorting. Note that the way org-entries-lessp is invoked by org-agenda-finalize-entries is still inefficient, because the same values (e.g. timestamps, priorities, etc.) are extracted from every pair of entries in each comparison within the sort. In the future, introducing a Schwartzian transform can probably address this. However the refactoring in this commit is a step in the right direction, and it also allows other code to determine which comparison is decisive in ordering any two elements. Signed-off-by: Adam Spiers <orgm...@adamspiers.org> --- lisp/org-agenda.el | 103 ++++++++++++++++++++------------------------- 1 file changed, 46 insertions(+), 57 deletions(-) diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el index 88bb3f90d..eadc7fedd 100644 --- a/lisp/org-agenda.el +++ b/lisp/org-agenda.el @@ -7187,65 +7187,54 @@ (defsubst org-cmp-habit-p (a b) (cond ((and ha (not hb)) -1) ((and (not ha) hb) +1)))) +(defun org-entries-cmp (a b) + "Iterate through the sorting criteria in +`org-agenda-sorting-strategy-selected' until a sorter returns a +definitive comparison, then return a cons cell (RESULT . SORTER)." + (let (sorted-by + sort-result + (ss org-agenda-sorting-strategy-selected)) + (while (and ss (not sorted-by)) + (let* ((sorter (car ss)) + (sorter-name (symbol-name sorter)) + ;; If sorter symbol ends in "-down" then pass the -up version + ;; to org-entries-cmp-1 and then negate the result. + (sorter-down-p (string-match "-down\\'" sorter-name)) + (up-sorter + (if sorter-down-p + (replace-regexp-in-string "-down\\'" "-up" sorter-name) + sorter-name))) + (setq sort-result (org-entries-cmp-1 a b (intern up-sorter))) + (setq ss (cdr ss)) + (when sort-result + (setq sort-result (if sorter-down-p (- sort-result) sort-result)) + (setq sorted-by sorter)))) + (cons sort-result sorted-by))) + +(defun org-entries-cmp-1 (a b sorter) + "Compare two entries via the given sorter." + (pcase sorter + ('timestamp-up (org-cmp-ts a b "")) + ('scheduled-up (org-cmp-ts a b "scheduled")) + ('deadline-up (org-cmp-ts a b "deadline")) + ('tsia-up (org-cmp-ts a b "timestamp_ia")) + ('ts-up (org-cmp-ts a b "timestamp")) + ('time-up (org-cmp-time a b)) + ('stats-up (org-cmp-values a b 'org-stats)) + ('priority-up (org-cmp-values a b 'priority)) + ('effort-up (org-cmp-effort a b)) + ('category-up (org-cmp-category a b)) + ('category-keep (if (org-cmp-category a b) +1 nil)) ;; FIXME: check this + ('tag-up (org-cmp-tag a b)) + ('todo-state-up (org-cmp-todo-state a b)) + ('habit-up (org-cmp-habit-p a b)) + ('alpha-up (org-cmp-alpha a b)) + ('user-defined-up (funcall org-agenda-cmp-user-defined a b)))) + (defun org-entries-lessp (a b) "Predicate for sorting agenda entries." - ;; The following variables will be used when the form is evaluated. - ;; So even though the compiler complains, keep them. - (let* ((ss org-agenda-sorting-strategy-selected) - (timestamp-up (and (org-em 'timestamp-up 'timestamp-down ss) - (org-cmp-ts a b ""))) - (timestamp-down (if timestamp-up (- timestamp-up) nil)) - (scheduled-up (and (org-em 'scheduled-up 'scheduled-down ss) - (org-cmp-ts a b "scheduled"))) - (scheduled-down (if scheduled-up (- scheduled-up) nil)) - (deadline-up (and (org-em 'deadline-up 'deadline-down ss) - (org-cmp-ts a b "deadline"))) - (deadline-down (if deadline-up (- deadline-up) nil)) - (tsia-up (and (org-em 'tsia-up 'tsia-down ss) - (org-cmp-ts a b "timestamp_ia"))) - (tsia-down (if tsia-up (- tsia-up) nil)) - (ts-up (and (org-em 'ts-up 'ts-down ss) - (org-cmp-ts a b "timestamp"))) - (ts-down (if ts-up (- ts-up) nil)) - (time-up (and (org-em 'time-up 'time-down ss) - (org-cmp-time a b))) - (time-down (if time-up (- time-up) nil)) - (stats-up (and (org-em 'stats-up 'stats-down ss) - (org-cmp-values a b 'org-stats))) - (stats-down (if stats-up (- stats-up) nil)) - (priority-up (and (org-em 'priority-up 'priority-down ss) - (org-cmp-values a b 'priority))) - (priority-down (if priority-up (- priority-up) nil)) - (effort-up (and (org-em 'effort-up 'effort-down ss) - (org-cmp-effort a b))) - (effort-down (if effort-up (- effort-up) nil)) - (category-up (and (or (org-em 'category-up 'category-down ss) - (memq 'category-keep ss)) - (org-cmp-category a b))) - (category-down (if category-up (- category-up) nil)) - (category-keep (if category-up +1 nil)) - (tag-up (and (org-em 'tag-up 'tag-down ss) - (org-cmp-tag a b))) - (tag-down (if tag-up (- tag-up) nil)) - (todo-state-up (and (org-em 'todo-state-up 'todo-state-down ss) - (org-cmp-todo-state a b))) - (todo-state-down (if todo-state-up (- todo-state-up) nil)) - (habit-up (and (org-em 'habit-up 'habit-down ss) - (org-cmp-habit-p a b))) - (habit-down (if habit-up (- habit-up) nil)) - (alpha-up (and (org-em 'alpha-up 'alpha-down ss) - (org-cmp-alpha a b))) - (alpha-down (if alpha-up (- alpha-up) nil)) - (need-user-cmp (org-em 'user-defined-up 'user-defined-down ss)) - user-defined-up user-defined-down) - (when (and need-user-cmp org-agenda-cmp-user-defined - (functionp org-agenda-cmp-user-defined)) - (setq user-defined-up - (funcall org-agenda-cmp-user-defined a b) - user-defined-down (if user-defined-up (- user-defined-up) nil))) - (cdr (assoc - (eval (cons 'or org-agenda-sorting-strategy-selected)) - '((-1 . t) (1 . nil) (nil . nil)))))) + (let ((sort-result (car (org-entries-cmp a b)))) + (cdr (assoc sort-result '((-1 . t) (1 . nil) (nil . nil)))))) ;;; Agenda restriction lock -- 2.28.0