From 2e47de365b4dcec6781f6150cea977fa8d8a94f2 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Johan=20Bockg=C3=A5rd?= <bojohan@gnu.org>
Date: Sun, 12 Apr 2015 16:26:52 +0200
Subject: [PATCH] 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 69f2792f4bd..41435b8b7b1 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 bca53c0c892..111459509bc 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 bbb278c863e..49603036ead 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)
-- 
2.11.4.GIT