master 541f693ca2e: Create macro 'pcase-let*-strict'

branch: master
commit 541f693ca2e8de166cfe52c39bbfc497142215e9
Author: Earl Hyatt <[email protected]>
Commit: Stefan Monnier <[email protected]>

    Create macro 'pcase-let*-strict'
    
    Create a version of 'pcase-let*' that signals an error when a 'pcase'
    pattern does not match its corresponding value.
    
    * lisp/emacs-lisp/pcase.el (pcase--let*): Add the optional argument
    'strict' to generate code for signaling an error when a 'pcase'
    pattern does not match its corresponding value.
    * lisp/emacs-lisp/pcase.el (pcase-let*-strict): Add the new macro.
    * test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-let*-strict):
    Add new test.
    * etc/NEWS (Pcase): Add heading for 'pcase'.
    * etc/NEWS (Add 'pcase-let*-strict'): Add news entry for new macro.
---
 doc/lispref/control.texi            |  7 ++++++
 etc/NEWS                            |  9 ++++++++
 lisp/emacs-lisp/pcase.el            | 45 +++++++++++++++++++++++++++++--------
 test/lisp/emacs-lisp/pcase-tests.el | 15 +++++++++++++
 4 files changed, 67 insertions(+), 9 deletions(-)

diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index d3662f727cc..909c69a854e 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1489,6 +1489,13 @@ introduced in each one of the @var{bindings} are available in the
 being available in @var{body}.
 @end defmac
 
+@defmac pcase-let*-strict bindings body@dots{}
+Like @code{pcase-let*}, but signals an error if a @var{pattern} does
+not match its corresponding @var{exp}.  For example, this can alert
+you when a value that you would like to destructure is not as
+expected.
+@end defmac
+
 @defmac pcase-dolist (pattern list) body@dots{}
 Execute @var{body} once for each element of @var{list}, on each
 iteration performing a destructuring binding of variables in
diff --git a/etc/NEWS b/etc/NEWS
index 4e3f8508da4..85d1af8d71c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -211,6 +211,15 @@ To install the grammars, use 'M-x markdown-ts-mode-install-parsers'.
 
 * Incompatible Lisp Changes in Emacs 32.1
 
+** Pcase
+
++++
+*** Add 'pcase-let*-strict'
+This macro is like 'pcase-let*', but signals an error if a 'pcase'
+pattern does not match its corresponding value.  This can be useful for
+destructuring values when you do not wish to continue if the
+corresponding value is not as expected.
+
 
 * Lisp Changes in Emacs 32.1
 
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 166b346fbbe..6f9312a50d3 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -268,22 +268,28 @@ nil."
     `(lambda ,args ,@(car parsed-body)
        (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body)))))
 
-(defun pcase--let* (bindings body)
+(defun pcase--let* (bindings body &optional strict)
   (cond
    ((null bindings) (macroexp-progn body))
    ((pcase--trivial-upat-p (caar bindings))
     (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
    (t
-    (let ((binding (pop bindings)))
+    (let* ((binding (pop bindings))
+           (x (gensym "x"))
+           (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
       (pcase--expand
        (cadr binding)
-       `((,(car binding) ,(pcase--let* bindings body))
-         ;; We can either signal an error here, or just use `pcase--dontcare'
-         ;; which generates more efficient code.  In practice, if we use
-         ;; `pcase--dontcare' we will still often get an error and the few
-         ;; cases where we don't do not matter that much, so
-         ;; it's a better choice.
-         (pcase--dontcare nil)))))))
+       `((,(car binding) ,(pcase--let* bindings body strict))
+         ,(if strict
+              `(,x (error "`pcase' pattern does not match value: %S %S"
+                          (quote ,(car binding))
+                          ,x))
+            ;; We can either signal an error here, or just use `pcase--dontcare'
+            ;; which generates more efficient code.  In practice, if we use
+            ;; `pcase--dontcare' we will still often get an error and the few
+            ;; cases where we don't do not matter that much, so
+            ;; it's a better choice.
+            '(pcase--dontcare nil))))))))
 
 ;;;###autoload
 (defmacro pcase-let* (bindings &rest body)
@@ -305,6 +311,27 @@ undetected, binding variables to arbitrary values, such as nil."
         (puthash bindings (cons body expansion) pcase--memoize)
         expansion))))
 
+;;;###autoload
+(defmacro pcase-let*-strict (bindings &rest body)
+  "Like `pcase-let*', but signal an error when a pattern does not match.
+As with `pcase-let*', BINDINGS are of the form (PATTERN EXP), but the
+EXP in each binding in BINDINGS can use the results of the destructuring
+bindings that precede it in BINDINGS' order.
+
+Each EXP should match its respective PATTERN (i.e. be of structure
+compatible to PATTERN); a mismatch may signal an error or may go
+undetected, binding variables to arbitrary values, such as nil."
+  (declare (indent 1)
+           (debug ((&rest (pcase-PAT &optional form)) body)))
+  (let ((cached (gethash bindings pcase--memoize)))
+    ;; cached = (BODY . EXPANSION)
+    (if (equal (car cached) body)
+        (cdr cached)
+      (let ((expansion (pcase--let* bindings body t)))
+        (puthash bindings (cons body expansion) pcase--memoize)
+        expansion))))
+
+
 ;;;###autoload
 (defmacro pcase-let (bindings &rest body)
   "Like `let', but supports destructuring BINDINGS using `pcase' patterns.
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index 9b8a643c731..866525343eb 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -210,4 +210,19 @@
     (should (equal (f4 nil) 1))
     (should (equal (f4 '(a)) 2))))
 
+(ert-deftest pcase-tests-let*-strict ()
+  (should (equal '(1 2 4 5)
+                 (pcase-let*-strict ((`(,a ,b) (list 1 2))
+                                     (`[,c ,d] (vector 4 5)))
+                   (list a b c d))))
+
+  (should (equal '(1 2 nil nil)
+                 (pcase-let* ((`(,a ,b) (list 1 2))
+                              (`(,c ,d) (vector 4 5)))
+                   (list a b c d))))
+
+  (should-error (pcase-let*-strict ((`(,a ,b) (list 1 2))
+                                    (`(,c ,d) (vector 4 5)))
+                  (list a b c d))))
+
 ;;; pcase-tests.el ends here.