bug#72328: [PATCH] Nested backquote in pcase

[Thuna <thuna.cing@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 533 bytes --]

Assuming a hypothetical `(pcase-assert OBJ PAT)' I would expect the
following to succeed:

  (pcase-assert '`,nil ``,nil)
  (pcase-assert '`,1 ``,,(pred integerp))
  (pcase-assert '`,@(list) ``,@,`(list . ,_))

which is to say: a comma should match its argument as a pattern only if
it escapes the original backquote (currently comma at all depths
"escape" the original backquote).

In case there is any interest in this, I have prepared a patch which
both adds the above as tests to pcase-tests.el and implements them in
pcase.el.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Handle-nested-backquotes-in-pcase.patch --]
[-- Type: text/x-patch, Size: 3037 bytes --]

From 9e7ab85e84bbdaf2520dee52aeec8b650b349c6a Mon Sep 17 00:00:00 2001
From: Thuna <thuna.cing@gmail.com>
Date: Sun, 28 Jul 2024 02:34:20 +0200
Subject: [PATCH] Handle nested backquotes in pcase

* lisp/emacs-lisp/pcase.el (pcase--expand-\`): Treat nested commas and
comma-ats as literal symbol matches, only consider their arguments as
patterns (or error in the case of comma-at) if the comma escapes the
original backquote.
* test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-nested-backquote):
Add tests for the behavior of nested backquote patterns.
---
 lisp/emacs-lisp/pcase.el            | 17 +++++++++++------
 test/lisp/emacs-lisp/pcase-tests.el |  5 +++++
 2 files changed, 16 insertions(+), 6 deletions(-)

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 5a7f3995311..a4c855432ce 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -1142,17 +1142,18 @@ \`
   (declare (debug (pcase-QPAT)))
   (pcase--expand-\` qpat))
 
-(defun pcase--expand-\` (qpat)
+(defun pcase--expand-\` (qpat &optional depth)
+  (unless depth (setq depth 0))
   (cond
-   ((eq (car-safe qpat) '\,) (cadr qpat))
-   ((or (eq (car-safe qpat) '\,@) (eq qpat '...))
+   ((and (<= depth 0) (eq (car-safe qpat) '\,)) (cadr qpat))
+   ((and (<= depth 0) (or (eq (car-safe qpat) '\,@) (eq qpat '...)))
     (error "Unsupported QPAT: %S" qpat))
    ((vectorp qpat)
     (let* ((trivial t)
            (contents nil)
            (upats nil))
       (dotimes (i (length qpat))
-        (let* ((upat (pcase--expand-\` (aref qpat i))))
+        (let* ((upat (pcase--expand-\` (aref qpat i) depth)))
           (if (eq (car-safe upat) 'quote)
               (push (cadr upat) contents)
             (setq trivial nil))
@@ -1163,8 +1164,12 @@ pcase--expand-\`
               (app length ,(length qpat))
               ,@(nreverse upats)))))
    ((consp qpat)
-    (let ((upata (pcase--expand-\` (car qpat)))
-          (upatd (pcase--expand-\` (cdr qpat))))
+    (let ((upata (pcase--expand-\` (car qpat) depth))
+          (upatd (pcase--expand-\`
+                  (cdr qpat)
+                  (cond ((eq (car qpat) '\`) (1+ depth))
+                        ((memq (car qpat) '(\, \,@)) (1- depth))
+                        (t depth)))))
       (if (and (eq (car-safe upata) 'quote) (eq (car-safe upatd) 'quote))
           `'(,(cadr upata) . ,(cadr upatd))
         `(and (pred consp)
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index e777b71920c..2649e754beb 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -191,4 +191,9 @@ pcase-tests-mutually-exclusive
         (should (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x)))
       (should-not (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x))))))
 
+(ert-deftest pcase-tests-nested-backquote ()
+  (should (pcase '`,nil (``,nil t)))
+  (should (pcase '`,1 (``,,(pred integerp) t)))
+  (should (pcase '`,@(list) (``,@,`(list . ,_) t))))
+
 ;;; pcase-tests.el ends here.
-- 
2.44.2