Add a function for building sort predicates

[Michael Heerdegen <michael_heerdegen@web.de>]

Hello,

I looked at how "package.el" defines the sort predicates for the used
tabulated list view - for example, `package-menu--status-predicate':

#+begin_src emacs-lisp
(defun package-menu--status-predicate (A B)
  "Predicate to sort \"*Packages*\" buffer by the status column.
This is used for `tabulated-list-format' in `package-menu-mode'."
  (let ((sA (aref (cadr A) 2))
        (sB (aref (cadr B) 2)))
    (cond ((string= sA sB)
           (package-menu--name-predicate A B))
          ((string= sA "new") t)
          ((string= sB "new") nil)
          ((string-prefix-p "avail" sA)
           (if (string-prefix-p "avail" sB)
               (package-menu--name-predicate A B)
             t))
          ((string-prefix-p "avail" sB) nil)
          ((string= sA "installed") t)
          ((string= sB "installed") nil)
          ((string= sA "dependency") t)
          ((string= sB "dependency") nil)
          ((string= sA "source") t)
          ((string= sB "source") nil)
          ((string= sA "unsigned") t)
          ...
          (t (string< sA sB)))))
#+end_src

This is hard to read and maintain, 0% user configurable, and it's not
easy to add additional "layers", like, "sort packages with equal states
first by archive name, and only then by name".

I want to suggest to add a function for defining sort predicates for
cases like these (especially having tabulated-list-mode in mind, but not
only - sorting is a common task).

Here is what I would imagine:

#+begin_src emacs-lisp
;; -*- lexical-binding: t -*-

(defun make-sort-pred (rules)
  "Return a sort predicate according to the sort RULES.
The returned predicate will accept two arguments A and B.  When
called, it will try RULES in order to decide whether A < B and
return non-nil in that case and nil when B <= A.  When no rule can
decide whether A < B, the predicate will also return nil.

RULES is a list of sort specifications using one of the formats
explained below.

The allowed formats of the specification lists in RULES are:

 -- (KEYFUN PRED)

This is like

       (lambda (a b)
         (funcall PRED (funcall KEYFUN a)
                       (funcall KEYFUN b)))

 -- (KEYFUN EQUAL-TEST . KEYLIST)

This spec allows to specify the order of keys explicitly when the
number of possible keys is small by specifying an accordingly
ordered KEYLIST directly.

A test using this rule form will first call KEYFUN with the
arguments A and B to get K-A and K-B.  Then, using the equality
test EQUAL-TEST, it is tested to which of the elements in KEYLIST
K-A and K-B are equal.  It is decided whether A < B using the
natural order of the KEYLIST elements.  Keys not found in KEYLIST
are treated it as if coming after all of its elements.  Elements
for that KEYFUN yields `equal' values are considered
indistinguishable.

 -- (KEYFUN EQUAL-TEST GET-KEYLIST)

This works exactly like the above spec - the only difference is
that GET-KEYLIST is either a symbol whose `symbol-value' will be
consulted, or a function accepting zero arguments to obtain the
KEYLIST to use, at run-time.  In the latter case the function
should be accordingly cheap when called and avoid unnecessary
consing.


Example 1: Sort a list like this:

  ((\"c\" 2) (\"a\" 3) (\"b\" 1) (\"b\" 3) (\"c\" 3)
   (\"c\" 1) (\"a\" 2) (\"b\" 2))

first by the first element, then by the second:

(sort \\='((\"c\" 2) (\"a\" 3) (\"b\" 1) (\"b\" 3) (\"c\" 3)
        (\"c\" 1) (\"a\" 2) (\"b\" 2))
      (make-sort-pred `((,#'car  ,#'string<)
                        (,#'cadr ,#'<))))

Example 2: Create a sort predicate suitable for sorting the list
of packages for M-x list-packages.  We want to have all \"new\"
packages listed first, then all obsolete packages, according to
the following list:

  (defvar my-package-menu--status-sorting-order
   \\='(\"new\" \"obsolete\" \"held\" \"external\" ...))

Package in the same category should be sorted by archive in a certain
order, and last by name:

(defalias \\='my-package-menu--status-predicate
  (make-sort-pred
   `((,(lambda (x) (aref (cadr x) 2))
      ,#'string= my-package-menu--status-sorting-order)
     (,(lambda (x) (package-desc-archive (car x)))
      ,#'equal \"gnu\" \"nongnu\" \"melpa\" nil)
     (,#'identity ,#'package-menu--name-predicate))))"

  (let ((result (make-symbol "result")))
    (cl-flet ((compare-with (test a b)
                (cond
                 ((funcall test a b) (throw result t))
                 ((funcall test b a) (throw result nil)))))
      (let ((rules
             ;; translate RULES to test functions
             (mapcar
              (pcase-lambda (`(,keyfun . ,rule))
                (if (cdr rule)
                    (let* ((test (car rule))
                           (testfun (lambda (x y)
                                      (funcall test y (funcall keyfun x))))
                           (keys (cdr rule))
                           (ckeys (car keys)))
                      (cl-flet ((keys (cond ((cdr keys) (lambda () keys))
                                            ((symbolp ckeys)
                                             (lambda () (symbol-value ckeys)))
                                            (t (lambda () (funcall ckeys))))))
                        (lambda (a b)
                          (cl-block nil
                            (let ((keys (keys)))
                              (while keys
                                (let ((key (pop keys)))
                                  (cond ((funcall testfun a key)
                                         (if (funcall testfun b key)
                                             (cl-return)
                                           (throw result t)))
                                        ((funcall testfun b key)
                                         (throw result nil))))))))))
                  (lambda (a b)
                    (compare-with
                     (car rule)
                     (funcall keyfun a) (funcall keyfun b)))))
                     rules)))

        (lambda (a b)
          (catch result
            ;; any rule throws 'result' when a<b is decidable with it
            (dolist (rule rules) (funcall rule a b))
            ;; no rule was able to decide - return nil for stable sorting
            nil))))))
#+end_src

Running time is comparable witho the existing code.

Would we want to add something like this?  And to which library?  I
would like to prepare a patch.


TIA,

Michael.