bug#27584: 26.0.50; alist-get: Add optional arg TESTFN

[Tino Calancha]

Stefan Monnier <monnier@IRO.UMontreal.CA> writes:


>>>> **) should be named `assoc-predicate' or differently?
>>> It's been called cl-assoc so far ;-)
>> Some day your dream will be fulfilled, and `cl-lib' will be preloaded at
>> startup.
>
> I'm not sure it's my dream, to tell you the truth: I like Scheme's
> choice of not treating "keyword symbols" specially, so macros can use
> them (because the keyword args aren't evaluated), but not functions.
> This ensures that the cost of keyword-argument parsing is only paid
> during macro expansion (where it's tolerable) but not at run-time
> (where it's much too costly and hence absolutely requires
> compiler-macro crutches).
thanks for th explanations.  I see your point now.
>> Then, we will not need things like `assoc-predicate'.
>
> In reality, my intention, beside putting a smiley, was to point you to another
> implementation which uses defun with a compiler-macro instead of
> defsubst.  Actually your assoc-predicate might be a good candidate for
> define-inline (which is in dire need of documentation.  I can't believe
> its author still hasn't bothered to put even a docstring).
>
> Something like
>
>     (define-inline assoc-predicate (elem list &optional pred)
>       (inline-letevals (elem list pred)
>         (pcase (inline-const-val pred)
>           ('eq (inline-quote (assq ,elem ,list)))
>           ((or 'equal 'nil) (inline-quote (assoc ,elem ,list)))
>           (_ (inline-quote (assoc-default ,elem ,list ,pred nil 'full))))))
Yes, that sounds much better!
I adapted your example into subr.el after stole from
`cl--compiler-macro-assoc' another optimization.
(See updated patch below)

Nico, one thing worries me is the following:
* After this patch, `map.el' v1.2 depends on Emacs version > 25:
* because it makes a call to `alist-get' with 5 parameters i.e., it
  uses TESTFN.
Is that a problem?

--8<-----------------------------cut here---------------start------------->8---
commit b4855d2d641b9fe4e6a49e898f797c40fe872281
Author: Tino Calancha <tino.calancha@gmail.com>
Date:   Fri Jul 7 15:29:15 2017 +0900

    alist-get: Add optional arg TESTFN
    
    If TESTFN is non-nil, then it is the predicate to lookup
    the alist.  Otherwise, use 'eq' (Bug#27584).
    * lisp/subr.el (assoc-default): Add optional arg FULL.
    (alist-get)
    * lisp/emacs-lisp/map.el (map-elt, map-put): Add optional arg TESTFN.
    * lisp/emacs-lisp/gv.el (alist-get): Update expander.
    * doc/lispref/lists.texi (Association Lists): Update manual.
    * etc/NEWS: Announce the changes.
    * test/lisp/emacs-lisp/map-tests.el (test-map-put-testfn-alist)
    (test-map-elt-testfn): New tests.

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 8eab2818f9..d2ae3028d8 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,10 +1589,14 @@ Association Lists
 @end smallexample
 @end defun
 
-@defun alist-get key alist &optional default remove
-This function is like @code{assq}, but instead of returning the entire
+@defun alist-get key alist &optional default remove testfn
+This function is like @code{assq} when @var{testfn} is @code{nil},
+but instead of returning the entire
 association for @var{key} in @var{alist},
 @w{@code{(@var{key} . @var{value})}}, it returns just the @var{value}.
+When @var{testfn} is non-@code{nil}, it returns @var{value} if @var{key}
+is equal to the car of an element of @var{alist}.  The equality is
+tested with @var{testfn}.
 If @var{key} is not found in @var{alist}, it returns @var{default}.
 
 This is a generalized variable (@pxref{Generalized Variables}) that
@@ -1640,7 +1644,7 @@ Association Lists
 @end smallexample
 @end defun
 
-@defun assoc-default key alist &optional test default
+@defun assoc-default key alist &optional test default full
 This function searches @var{alist} for a match for @var{key}.  For each
 element of @var{alist}, it compares the element (if it is an atom) or
 the element's @sc{car} (if it is a cons) against @var{key}, by calling
@@ -1652,7 +1656,8 @@ Association Lists
 
 If an alist element matches @var{key} by this criterion,
 then @code{assoc-default} returns a value based on this element.
-If the element is a cons, then the value is the element's @sc{cdr}.
+If the element is a cons, then the value is the element if @var{full}
+is non-@code{nil}, or the element's @sc{cdr} if @var{full} is @code{nil}.
 Otherwise, the return value is @var{default}.
 
 If no alist element matches @var{key}, @code{assoc-default} returns
diff --git a/etc/NEWS b/etc/NEWS
index 13805ce0da..a395ac7aec 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1050,6 +1050,13 @@ break.
 
 * Lisp Changes in Emacs 26.1
 
++++
+** New optional argument FULL in 'assoc-default', to return the full
+matching element.
+
++++
+** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.
+
 ** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2
 contain the same elements, regardless of the order.
 
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index c5c12a6414..166881a458 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -377,10 +377,12 @@ setf
     `(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
 
 (gv-define-expander alist-get
-  (lambda (do key alist &optional default remove)
+  (lambda (do key alist &optional default remove testfn)
     (macroexp-let2 macroexp-copyable-p k key
       (gv-letplace (getter setter) alist
-        (macroexp-let2 nil p `(assq ,k ,getter)
+        (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
+                                  (assoc-default ,k ,getter ,testfn nil 'full)
+                                (assq ,k ,getter))
           (funcall do (if (null default) `(cdr ,p)
                         `(if ,p (cdr ,p) ,default))
                    (lambda (v)
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index a89457e877..e25502d76f 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -4,7 +4,7 @@
 
 ;; Author: Nicolas Petton <nicolas@petton.fr>
 ;; Keywords: convenience, map, hash-table, alist, array
-;; Version: 1.1
+;; Version: 1.2
 ;; Package: map
 
 ;; Maintainer: emacs-devel@gnu.org
@@ -93,11 +93,11 @@ map-let
            ((arrayp ,map-var) ,(plist-get args :array))
            (t (error "Unsupported map: %s" ,map-var)))))
 
-(defun map-elt (map key &optional default)
+(defun map-elt (map key &optional default testfn)
   "Lookup KEY in MAP and return its associated value.
 If KEY is not found, return DEFAULT which defaults to nil.
 
-If MAP is a list, `eql' is used to lookup KEY.
+If MAP is a list, TESTFN is used to lookup KEY if non-nil or `eql' if nil.
 
 MAP can be a list, hash-table or array."
   (declare
@@ -106,30 +106,31 @@ map-elt
       (gv-letplace (mgetter msetter) `(gv-delay-error ,map)
         (macroexp-let2* nil
             ;; Eval them once and for all in the right order.
-            ((key key) (default default))
+            ((key key) (default default) (testfn testfn))
           `(if (listp ,mgetter)
                ;; Special case the alist case, since it can't be handled by the
                ;; map--put function.
                ,(gv-get `(alist-get ,key (gv-synthetic-place
                                           ,mgetter ,msetter)
-                                    ,default)
+                                    ,default nil ,testfn)
                         do)
              ,(funcall do `(map-elt ,mgetter ,key ,default)
                        (lambda (v) `(map--put ,mgetter ,key ,v)))))))))
   (map--dispatch map
-    :list (alist-get key map default)
+    :list (alist-get key map default nil testfn)
     :hash-table (gethash key map default)
     :array (if (and (>= key 0) (< key (seq-length map)))
                (seq-elt map key)
              default)))
 
-(defmacro map-put (map key value)
+(defmacro map-put (map key value &optional testfn)
   "Associate KEY with VALUE in MAP and return VALUE.
 If KEY is already present in MAP, replace the associated value
 with VALUE.
+When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
 
 MAP can be a list, hash-table or array."
-  `(setf (map-elt ,map ,key) ,value))
+  `(setf (map-elt ,map ,key nil ,testfn) ,value))
 
 (defun map-delete (map key)
   "Delete KEY from MAP and return MAP.
diff --git a/lisp/subr.el b/lisp/subr.el
index a9edff6166..01c6c1628f 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -650,23 +650,27 @@ copy-tree
 
 ;;;; Various list-search functions.
 
-(defun assoc-default (key alist &optional test default)
+(defun assoc-default (key alist &optional test default full)
   "Find object KEY in a pseudo-alist ALIST.
 ALIST is a list of conses or objects.  Each element
  (or the element's car, if it is a cons) is compared with KEY by
  calling TEST, with two arguments: (i) the element or its car,
  and (ii) KEY.
 If that is non-nil, the element matches; then `assoc-default'
- returns the element's cdr, if it is a cons, or DEFAULT if the
- element is not a cons.
+ returns the element, if it is a cons and FULL is non-nil,
+ or the element's cdr, if it is a cons and FULL is nil,
+ or DEFAULT if the element is not a cons.
 
 If no element matches, the value is nil.
 If TEST is omitted or nil, `equal' is used."
   (let (found (tail alist) value)
     (while (and tail (not found))
       (let ((elt (car tail)))
-       (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
-         (setq found t value (if (consp elt) (cdr elt) default))))
+        (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
+          (setq found t
+                value (cond ((consp elt)
+                             (if full elt (cdr elt)))
+                            (t default)))))
       (setq tail (cdr tail)))
     value))
 
@@ -725,15 +729,18 @@ rassq-delete-all
        (setq tail tail-cdr))))
   alist)
 
-(defun alist-get (key alist &optional default remove)
-  "Return the value associated with KEY in ALIST, using `assq'.
+(defun alist-get (key alist &optional default remove testfn)
+  "Return the value associated with KEY in ALIST.
 If KEY is not found in ALIST, return DEFAULT.
+Use TESTFN to lookup in the alist if non-nil.  Otherwise, use `assq'.
 
 This is a generalized variable suitable for use with `setf'.
 When using it to set a value, optional argument REMOVE non-nil
 means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
   (ignore remove) ;;Silence byte-compiler.
-  (let ((x (assq key alist)))
+  (let ((x (if (and testfn (not (eq testfn 'eq)))
+               (assoc-default key alist testfn nil 'full)
+             (assq key alist))))
     (if x (cdr x) default)))
 
 (defun remove (elt seq)
diff --git a/test/lisp/emacs-lisp/map-tests.el 
b/test/lisp/emacs-lisp/map-tests.el
index 07e85cc539..15b0655040 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -63,6 +63,11 @@ with-maps-do
   (with-maps-do map
     (should (= 5 (map-elt map 7 5)))))
 
+(ert-deftest test-map-elt-testfn ()
+  (let ((map (list (cons "a" 1) (cons "b" 2))))
+    (should-not (map-elt map "a"))
+    (should (map-elt map "a" nil 'equal))))
+
 (ert-deftest test-map-elt-with-nil-value ()
   (should (null (map-elt '((a . 1)
                            (b))
@@ -94,6 +99,13 @@ with-maps-do
     (should (eq (map-elt alist 2)
                 'b))))
 
+(ert-deftest test-map-put-testfn-alist ()
+  (let ((alist (list (cons "a" 1) (cons "b" 2))))
+    (map-put alist "a" 3 'equal)
+    (should-not (cddr alist))
+    (map-put alist "a" 9)
+    (should (cddr alist))))
+
 (ert-deftest test-map-put-return-value ()
   (let ((ht (make-hash-table)))
     (should (eq (map-put ht 'a 'hello) 'hello))))
commit 536e4cf1dd8df61edb4bbc580ba1da787ba57f43
Author: Tino Calancha <tino.calancha@gmail.com>
Date:   Fri Jul 7 15:31:15 2017 +0900

    assoc-predicate: New defun
    
    Add new function like 'assoc' with an optional arg PRED,
    a predicate to compare the elements in the alist.
    * lisp/subr.el (assoc-predicate): New defun.
    (alist-get):
    * lisp/emacs-lisp/gv.el (alist-get): Use it.
    * test/lisp/subr-tests.el (subr-assoc-default, subr-assoc-predicate):
    New tests.
    * doc/lispref/lists.texi (Association Lists): Update manual.
    * etc/NEWS: Announce the feature.

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index d2ae3028d8..b2a0b2df09 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,6 +1589,25 @@ Association Lists
 @end smallexample
 @end defun
 
+@defun assoc-predicate key alist &optional pred
+This function is like @code{assoc} in that it returns the first
+association for @var{key} in @var{alist}, but if @code{pred} is
+non-@code{nil}, then it makes the comparison using @code{pred}
+instead of @code{equal}.  @code{assoc-predicate} returns @code{nil}
+if no association in @var{alist} has a @sc{car}, @var{x}, satisfying
+@code{(funcall pred x key)}.
+
+@smallexample
+(setq leaves
+      '(("simple leaves" . oak)
+        ("compound leaves" . horsechestnut)))
+
+(assoc-predicate "simple leaves" leaves 'string=)
+     @result{} ("simple leaves" . oak)
+@end smallexample
+
+@end defun
+
 @defun alist-get key alist &optional default remove testfn
 This function is like @code{assq} when @var{testfn} is @code{nil},
 but instead of returning the entire
diff --git a/etc/NEWS b/etc/NEWS
index a395ac7aec..e988186b6c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1050,6 +1050,11 @@ break.
 
 * Lisp Changes in Emacs 26.1
 
+
++++
+** New defun 'assoc-predicate', like 'assoc' with an optional argument
+PRED, a predicate to compare the elements in the alist.
+
 +++
 ** New optional argument FULL in 'assoc-default', to return the full
 matching element.
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 166881a458..29b85e280e 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -381,7 +381,7 @@ setf
     (macroexp-let2 macroexp-copyable-p k key
       (gv-letplace (getter setter) alist
         (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
-                                  (assoc-default ,k ,getter ,testfn nil 'full)
+                                  (assoc-predicate ,k ,getter ,testfn)
                                 (assq ,k ,getter))
           (funcall do (if (null default) `(cdr ,p)
                         `(if ,p (cdr ,p) ,default))
diff --git a/lisp/subr.el b/lisp/subr.el
index 01c6c1628f..80b10a62c0 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -674,6 +674,19 @@ assoc-default
       (setq tail (cdr tail)))
     value))
 
+(defun assoc-predicate (key alist &optional pred)
+  "Like `assoc' but compare keys with TEST."
+  (declare (compiler-macro
+            (lambda (_)
+              `(pcase ,pred
+                 ('eq (assq ,key ,alist))
+                 ((or 'equal 'nil) (assoc ,key ,alist))
+                 ((guard (and (macroexp-const-p ,key) (eq ,pred 'eql)))
+                  (if (floatp ,key)
+                      (assoc ,key ,alist) (assq ,key ,alist)))
+                 (_ (assoc-default ,key ,alist ,pred nil 'full))))))
+  (assoc-default key alist pred nil 'full))
+
 (defun assoc-ignore-case (key alist)
   "Like `assoc', but ignores differences in case and text representation.
 KEY must be a string.  Upper-case and lower-case letters are treated as equal.
@@ -739,7 +752,7 @@ alist-get
 means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
   (ignore remove) ;;Silence byte-compiler.
   (let ((x (if (and testfn (not (eq testfn 'eq)))
-               (assoc-default key alist testfn nil 'full)
+               (assoc-predicate key alist testfn)
              (assq key alist))))
     (if x (cdr x) default)))
 
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 54f4ab5d1b..ab806f74c3 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -325,6 +325,23 @@ subr-tests--this-file
       (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default 
"")))
       (should (string= default res)))))
 
+(ert-deftest subr-assoc-default ()
+  (let ((alist (list (cons "a" 1) (cons "b" 2) "c")))
+    (should (assoc-default "b" alist))
+    (should-not (assoc-default "b" alist 'eq))
+    (should-not (assoc-default "c" alist 'eq 'foo))
+    ;; Return 4th argument if the found element is an atom.
+    (should (equal 'foo (assoc-default "c" alist 'equal 'foo)))
+    (should (equal 2 (assoc-default "b" alist 'equal nil)))
+    (should (equal '("b" . 2) (assoc-default "b" alist 'equal nil 'full)))))
+
+(ert-deftest subr-assoc-predicate ()
+  (let ((alist (list (cons "a" 1) (cons "b" 2) "c")))
+    (should (assoc-predicate "b" alist))
+    (should-not (assoc-predicate "b" alist 'eq))
+    (should-not (assoc-predicate "c" alist 'eq))
+    (should-not (assoc-predicate "c" alist 'equal))
+    (should (equal '("b" . 2) (assoc-predicate "b" alist 'equal)))))
 
 (provide 'subr-tests)
 ;;; subr-tests.el ends here
--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 26.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.11)
 of 2017-07-07
Repository revision: 51275358e91d654e0cb49b749bf83d2fa19476c7