master 0ab56a4 1/2: * lisp/emacs-lisp/pcase.el: Add support for `not` to `pred`

[Stefan Monnier]

branch: master
commit 0ab56a4e935b3aa759229923804ba33c841f425c
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * lisp/emacs-lisp/pcase.el: Add support for `not` to `pred`
    
    (pcase--split-pred, pcase--funcall): Adjust for `not`.
    (pcase--get-macroexpander): New function.
    (pcase--edebug-match-macro, pcase--make-docstring)
    (pcase--macroexpand): Use it.
    
    * lisp/emacs-lisp/radix-tree.el (radix-tree-leaf): Use it!
    
    * doc/lispref/control.texi (The @code{pcase} macro): Document it.
    
    * lisp/emacs-lisp/ert.el (ert--explain-equal-rec): Remove redundant test.
---
 doc/lispref/control.texi            |  5 ++--
 etc/NEWS                            |  6 +++++
 lisp/emacs-lisp/ert.el              |  4 ++--
 lisp/emacs-lisp/pcase.el            | 46 +++++++++++++++++++++++++++++--------
 lisp/emacs-lisp/radix-tree.el       |  7 +++---
 test/lisp/emacs-lisp/pcase-tests.el |  4 ++++
 6 files changed, 56 insertions(+), 16 deletions(-)

diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 55bcddb..80e9eb7 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -557,8 +557,9 @@ Likewise, it makes no sense to bind keyword symbols
 
 @item (pred @var{function})
 Matches if the predicate @var{function} returns non-@code{nil}
-when called on @var{expval}.
-the predicate @var{function} can have one of the following forms:
+when called on @var{expval}.  The test can be negated with the syntax
+@code{(pred (not @var{function}))}.
+The predicate @var{function} can have one of the following forms:
 
 @table @asis
 @item function name (a symbol)
diff --git a/etc/NEWS b/etc/NEWS
index fc7dcbc..359d308 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -326,6 +326,12 @@ the buffer cycles the whole buffer between "only top-level 
headings",
 
 * Changes in Specialized Modes and Packages in Emacs 28.1
 
+** pcase
++++
+*** The `pred` pattern can now take the form (pred (not FUN)).
+This is like (pred (lambda (x) (not (FUN x)))) but results
+in better code.
+
 +++
 ** profiler.el
 The results displayed by 'profiler-report' now have the usage figures
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 5851754..fdbf953 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil."
 Returns nil if they are."
   (if (not (eq (type-of a) (type-of b)))
       `(different-types ,a ,b)
-    (pcase-exhaustive a
+    (pcase a
       ((pred consp)
        (let ((a-length (proper-list-p a))
              (b-length (proper-list-p b)))
@@ -538,7 +538,7 @@ Returns nil if they are."
                   for xi = (ert--explain-equal-rec ai bi)
                   do (when xi (cl-return `(array-elt ,i ,xi)))
                   finally (cl-assert (equal a b) t))))
-      ((pred atom)
+      (_
        (if (not (equal a b))
            (if (and (symbolp a) (symbolp b) (string= a b))
                `(different-symbols-with-the-same-name ,a ,b)
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 72ea1ba..bfd577c 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -39,10 +39,10 @@
 ;; - along these lines, provide patterns to match CL structs.
 ;; - provide something like (setq VAR) so a var can be set rather than
 ;;   let-bound.
-;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
-;;   this :-()
+;; - provide a way to fallthrough to subsequent cases
+;;   (e.g. Like Racket's (=> ID).
 ;; - try and be more clever to reduce the size of the decision tree, and
-;;   to reduce the number of leaves that need to be turned into function:
+;;   to reduce the number of leaves that need to be turned into functions:
 ;;   - first, do the tests shared by all remaining branches (it will have
 ;;     to be performed anyway, so better do it first so it's shared).
 ;;   - then choose the test that discriminates more (?).
@@ -97,11 +97,15 @@
 (declare-function get-edebug-spec "edebug" (symbol))
 (declare-function edebug-match "edebug" (cursor specs))
 
+(defun pcase--get-macroexpander (s)
+  "Return the macroexpander for pcase pattern head S, or nil"
+  (get s 'pcase-macroexpander))
+
 (defun pcase--edebug-match-macro (cursor)
   (let (specs)
     (mapatoms
      (lambda (s)
-       (let ((m (get s 'pcase-macroexpander)))
+       (let ((m (pcase--get-macroexpander s)))
         (when (and m (get-edebug-spec m))
           (push (cons (symbol-name s) (get-edebug-spec m))
                 specs)))))
@@ -128,6 +132,7 @@ PATTERN matches.  PATTERN can take one of the forms:
                    If a SYMBOL is used twice in the same pattern
                    the second occurrence becomes an `eq'uality test.
   (pred FUN)       matches if FUN called on EXPVAL returns non-nil.
+  (pred (not FUN)) matches if FUN called on EXPVAL returns nil.
   (app FUN PAT)    matches if FUN called on EXPVAL matches PAT.
   (guard BOOLEXP)  matches if BOOLEXP evaluates to non-nil.
   (let PAT EXPR)   matches if EXPR matches PAT.
@@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples."
       (let (more)
         ;; Collect all the extensions.
         (mapatoms (lambda (symbol)
-                    (let ((me (get symbol 'pcase-macroexpander)))
+                    (let ((me (pcase--get-macroexpander symbol)))
                       (when me
                         (push (cons symbol me)
                               more)))))
@@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'.
      ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
      ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
      (t
-      (let* ((expander (get head 'pcase-macroexpander))
+      (let* ((expander (pcase--get-macroexpander head))
              (npat (if expander (apply expander (cdr pat)))))
         (if (null npat)
             (error (if expander
@@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form:
     '(:pcase--succeed . nil))))
 
 (defun pcase--split-pred (vars upat pat)
+  "Indicate the overlap or mutual-exclusion between UPAT and PAT.
+More specifically retuns a pair (A . B) where A indicates whether PAT
+can match when UPAT has matched, and B does the same for the case
+where UPAT failed to match.
+A and B can be one of:
+- nil if we don't know
+- `:pcase--fail' if UPAT match's result implies that PAT can't match
+- `:pcase--succeed' if UPAT match's result implies that PAT matches"
   (let (test)
     (cond
      ((and (equal upat pat)
@@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form:
                ;; and catch at least the easy cases such as (bug#14773).
                (not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
       '(:pcase--succeed . :pcase--fail))
+     ;; In case UPAT is of the form (pred (not PRED))
+     ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
+      (let* ((test (cadr (cadr upat)))
+             (res (pcase--split-pred vars `(pred ,test) pat)))
+        (cons (cdr res) (car res))))
+     ;; In case PAT is of the form (pred (not PRED))
+     ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
+      (let* ((test (cadr (cadr pat)))
+             (res (pcase--split-pred vars upat `(pred ,test)))
+             (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail)
+                                   ((eq x :pcase--fail) :pcase--succeed)))))
+        (cons (funcall reverse (car res))
+              (funcall reverse (cdr res)))))
      ((and (eq 'pred (car upat))
            (let ((otherpred
                   (cond ((eq 'pred (car-safe pat)) (cadr pat))
@@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form:
 
 (defun pcase--funcall (fun arg vars)
   "Build a function call to FUN with arg ARG."
-  (if (symbolp fun)
-      `(,fun ,arg)
+  (cond
+   ((symbolp fun) `(,fun ,arg))
+   ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars)))
+   (t
     (let* (;; `env' is an upper bound on the bindings we need.
            (env (mapcar (lambda (x) (list (car x) (cdr x)))
                         (macroexp--fgrep vars fun)))
@@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form:
         ;; Let's not replace `vars' in `fun' since it's
         ;; too difficult to do it right, instead just
         ;; let-bind `vars' around `fun'.
-        `(let* ,env ,call)))))
+        `(let* ,env ,call))))))
 
 (defun pcase--eval (exp vars)
   "Build an expression that will evaluate EXP."
diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el
index 6a483a6..0905ac6 100644
--- a/lisp/emacs-lisp/radix-tree.el
+++ b/lisp/emacs-lisp/radix-tree.el
@@ -198,9 +198,10 @@ If not found, return nil."
   (pcase-defmacro radix-tree-leaf (vpat)
     "Pattern which matches a radix-tree leaf.
 The pattern VPAT is matched against the leaf's carried value."
-    ;; FIXME: We'd like to use a negative pattern (not consp), but pcase
-    ;; doesn't support it.  Using `atom' works but generates sub-optimal code.
-    `(or `(t . ,,vpat) (and (pred atom) ,vpat))))
+    ;; We used to use `(pred atom)', but `pcase' doesn't understand that
+    ;; `atom' is equivalent to the negation of `consp' and hence generates
+    ;; suboptimal code.
+    `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat))))
 
 (defun radix-tree-iter-subtrees (tree fun)
   "Apply FUN to every immediate subtree of radix TREE.
diff --git a/test/lisp/emacs-lisp/pcase-tests.el 
b/test/lisp/emacs-lisp/pcase-tests.el
index 1b06c6e..e6f4c09 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -32,6 +32,10 @@
   (should (equal (pcase '(2 . 3)        ;bug#18554
                    (`(,hd . ,(and (pred atom) tl)) (list hd tl))
                    ((pred consp) nil))
+                 '(2 3)))
+  (should (equal (pcase '(2 . 3)
+                   (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl))
+                   ((pred consp) nil))
                  '(2 3))))
 
 (pcase-defmacro pcase-tests-plus (pat n)