[Emacs-diffs] master 2e47de3 3/3: Support debug declarations in pcase macros

[Johan Bockgard]

branch: master
commit 2e47de365b4dcec6781f6150cea977fa8d8a94f2
Author: Johan Bockgård <address@hidden>
Commit: Johan Bockgård <address@hidden>

    Support debug declarations in pcase macros
    
    * lisp/emacs-lisp/pcase.el (pcase-MACRO): New edebug spec.
    (pcase-UPAT): Use it.  Remove "`".
    (pcase--edebug-match-macro): New function.
    (pcase-defmacro): Support debug declarations.
    
    * lisp/emacs-lisp/cl-macs.el (cl-struct) <pcase-defmacro>:
    * lisp/emacs-lisp/eieio.el (eieio) <pcase-defmacro>:
    * lisp/emacs-lisp/pcase.el (\`): <pcase-defmacro>: Add debug declaration.
---
 lisp/emacs-lisp/cl-macs.el |    1 +
 lisp/emacs-lisp/eieio.el   |    1 +
 lisp/emacs-lisp/pcase.el   |   38 +++++++++++++++++++++++++++-----------
 3 files changed, 29 insertions(+), 11 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 69f2792..41435b8 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2780,6 +2780,7 @@ non-nil value, that slot cannot be set via `setf'.
 Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
 field NAME is matched against UPAT, or they can be of the form NAME which
 is a shorthand for (NAME NAME)."
+  (declare (debug (sexp &rest [&or (sexp pcase-UPAT) sexp])))
   `(and (pred (pcase--flip cl-typep ',type))
         ,@(mapcar
            (lambda (field)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index bca53c0..1114595 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -348,6 +348,7 @@ variable name of the same name as the slot."
 Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
 field NAME is matched against UPAT, or they can be of the form NAME which
 is a shorthand for (NAME NAME)."
+  (declare (debug (&rest [&or (sexp pcase-UPAT) sexp])))
   (let ((is (make-symbol "table")))
     ;; FIXME: This generates a horrendous mess of redundant let bindings.
     ;; `pcase' needs to be improved somehow to introduce let-bindings more
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index bbb278c..4960303 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -75,18 +75,11 @@
   (&or symbolp
        ("or" &rest pcase-UPAT)
        ("and" &rest pcase-UPAT)
-       ("`" pcase-QPAT)
        ("guard" form)
        ("let" pcase-UPAT form)
        ("pred" pcase-FUN)
        ("app" pcase-FUN pcase-UPAT)
-       sexp))
-
-(def-edebug-spec
-  pcase-QPAT
-  (&or ("," pcase-UPAT)
-       (pcase-QPAT . pcase-QPAT)
-       (vector &rest pcase-QPAT)
+       pcase-MACRO
        sexp))
 
 (def-edebug-spec
@@ -96,6 +89,18 @@
        (functionp &rest form)
        sexp))
 
+(def-edebug-spec pcase-MACRO pcase--edebug-match-macro)
+
+(defun pcase--edebug-match-macro (cursor)
+  (let (specs)
+    (mapatoms
+     (lambda (s)
+       (let ((m (get s 'pcase-macroexpander)))
+        (when (and m (get-edebug-spec m))
+          (push (cons (symbol-name s) (get-edebug-spec m))
+                specs)))))
+    (edebug-match cursor (cons '&or specs))))
+
 ;;;###autoload
 (defmacro pcase (exp &rest cases)
   "Perform ML-style pattern matching on EXP.
@@ -367,11 +372,14 @@ of the form (UPAT EXP)."
 (defmacro pcase-defmacro (name args &rest body)
   "Define a pcase UPattern macro."
   (declare (indent 2) (debug defun) (doc-string 3))
-  (let ((fsym (intern (format "%s--pcase-macroexpander" name))))
-    ;; Add the function via `fsym', so that an autoload cookie placed
-    ;;  on a pcase-defmacro will cause the macro to be loaded on demand.
+  ;; Add the function via `fsym', so that an autoload cookie placed
+  ;; on a pcase-defmacro will cause the macro to be loaded on demand.
+  (let ((fsym (intern (format "%s--pcase-macroexpander" name)))
+       (decl (assq 'declare body)))
+    (when decl (setq body (remove decl body)))
     `(progn
        (defun ,fsym ,args ,@body)
+       (put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
        (put ',name 'pcase-macroexpander #',fsym))))
 
 (defun pcase--match (val upat)
@@ -833,6 +841,13 @@ Otherwise, it defers to REST which is a list of branches 
of the form
        (t (error "Unknown internal pattern `%S'" upat)))))
    (t (error "Incorrect MATCH %S" (car matches)))))
 
+(def-edebug-spec
+  pcase-QPAT
+  (&or ("," pcase-UPAT)
+       (pcase-QPAT . pcase-QPAT)
+       (vector &rest pcase-QPAT)
+       sexp))
+
 (pcase-defmacro \` (qpat)
   "Backquote-style pcase patterns.
 QPAT can take the following forms:
@@ -842,6 +857,7 @@ QPAT can take the following forms:
   ,UPAT                 matches if the UPattern UPAT matches.
   STRING                matches if the object is `equal' to STRING.
   ATOM                  matches if the object is `eq' to ATOM."
+  (declare (debug (pcase-QPAT)))
   (cond
    ((eq (car-safe qpat) '\,) (cadr qpat))
    ((vectorp qpat)