* lisp/emacs-lisp/edebug.el (edebug--handle-&-spec-op) <&lookup>: New method

* doc/lispref/edebug.texi (Specification List): Document it.

* lisp/emacs-lisp/pcase.el (pcase-PAT): Use it.
(pcase-MACRO): Remove Edebug element.
(pcase--get-edebug-spec): New function.
(pcase--edebug-match-macro): Remove function.

diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 569545d83f13e8cde515b659fa3ecd4c6a3b5a55..693d0e0630a796ec3e7c1c2709f835330fc175b9 100644 (file)
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -1370,6 +1370,17 @@ is primarily used to generate more specific syntax error messages.  See
 edebug-spec; it aborts the instrumentation, displaying the message in
 the minibuffer.
 
+@item &lookup
+Selects a specification based on the code being instrumented.
+It takes the form @code{&lookup @var{spec} @var{fun} @var{args...}}
+and means that Edebug will first match @var{spec} against the code and
+then match the rest against the specification returned by calling
+@var{fun} with the concatenation of @var{args...} and the code that
+matched @code{spec}.  For example @code{(&lookup symbolp
+pcase--get-edebug-spec)} matches sexps whose first element is
+a symbol and whose subsequent elements must obey the spec associated
+with that head symbol according to @code{pcase--get-edebug-spec}.
+
 @item @var{other-symbol}
 @cindex indirect specifications
 Any other symbol in a specification list may be a predicate or an

diff --git a/etc/NEWS b/etc/NEWS
index 228b773cb271fc8e5991a2070d29ee5561843686..fe626fec7ec62832d80eb93ca9c606e84773b600 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -938,14 +938,17 @@ To customize obsolete user options, use 'customize-option' or
 ---
 *** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'.
 
+*** Edebug specification lists can use some new keywords:
+
++++
+**** '&lookup SPEC FUN ARGS...' lets FUN compute the specs to use
+
 +++
-*** Edebug specification lists can use the new keyword '&error', which
-unconditionally aborts the current edebug instrumentation with the
-supplied error message.
+**** '&error MSG' unconditionally aborts the current edebug instrumentation.
 
-*** Edebug specification lists can use the new keyword ':unique',
-which appends a unique suffix to the Edebug name of the current
-definition.
++++
+**** ':unique STRING' appends STRING to the Edebug name of the current
+definition to (hopefully) make it more unique.
 
 ** ElDoc
 

diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 04a4829c5e68118e629f9a205ad028397c7eb50c..782299454ea005423beffb5389c83b07532a56c1 100644 (file)
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -55,6 +55,7 @@
 (require 'backtrace)
 (require 'macroexp)
 (require 'cl-lib)
+(require 'seq)
 (eval-when-compile (require 'pcase))
 
 ;;; Options
@@ -1866,6 +1867,22 @@ contains a circular object."
       (apply #'edebug-no-match cursor "Expected one of" original-specs))
     ))
 
+(cl-defmethod edebug--handle-&-spec-op ((_ (eql &lookup)) cursor specs)
+  "Compute the specs for `&lookup SPEC FUN ARGS...'.
+Extracts the head of the data by matching it against SPEC,
+and then matches the rest against the output of (FUN ARGS... HEAD)."
+  (pcase-let*
+      ((`(,spec ,fun . ,args) specs)
+       (exps (edebug-cursor-expressions cursor))
+       (instrumented-head (edebug-match-one-spec cursor (or spec 'sexp)))
+       (consumed (- (length exps)
+                    (length (edebug-cursor-expressions cursor))))
+       (newspecs (apply fun (append args (seq-subseq exps 0 consumed)))))
+    (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps)))
+    ;; FIXME: What'd be the difference if we used `edebug-match-sublist',
+    ;; which is what `edebug-list-form-args' uses for the similar purpose
+    ;; when matching "normal" forms?
+    (append instrumented-head (edebug-match cursor newspecs))))
 
 (cl-defmethod edebug--handle-&-spec-op ((_ (eql &not)) cursor specs)
   ;; If any specs match, then fail

diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 7a88bdf8de5b5cbc3a0f3a915d2d22529d941eec..d6c96c1ec825eea1499cf72b5921035256ec4be6 100644 (file)
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -62,45 +62,32 @@
 
 (defvar pcase--dontwarn-upats '(pcase--dontcare))
 
-(def-edebug-spec
-  pcase-PAT
-  (&or symbolp
-       ("or" &rest pcase-PAT)
-       ("and" &rest pcase-PAT)
-       ("guard" form)
-       ("pred" pcase-FUN)
-       ("app" pcase-FUN pcase-PAT)
-       pcase-MACRO
+(def-edebug-spec pcase-PAT
+  (&or (&lookup symbolp pcase--get-edebug-spec)
        sexp))
 
-(def-edebug-spec
-  pcase-FUN
+(def-edebug-spec pcase-FUN
   (&or lambda-expr
        ;; Punt on macros/special forms.
        (functionp &rest form)
        sexp))
 
-;; See bug#24717
-(put 'pcase-MACRO 'edebug-form-spec #'pcase--edebug-match-macro)
-
 ;; Only called from edebug.
 (declare-function edebug-get-spec "edebug" (symbol))
-(declare-function edebug-match "edebug" (cursor specs))
+(defun pcase--get-edebug-spec (head)
+  (or (alist-get head '((quote sexp)
+                        (or    &rest pcase-PAT)
+                        (and   &rest pcase-PAT)
+                        (guard form)
+                        (pred  &or ("not" pcase-FUN) pcase-FUN)
+                        (app   pcase-FUN pcase-PAT)))
+      (let ((me (pcase--get-macroexpander head)))
+        (and me (symbolp me) (edebug-get-spec me)))))
 
 (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 (pcase--get-macroexpander s)))
-        (when (and m (edebug-get-spec m))
-          (push (cons (symbol-name s) (edebug-get-spec m))
-                specs)))))
-    (edebug-match cursor (cons '&or specs))))
-
 ;;;###autoload
 (defmacro pcase (exp &rest cases)
   ;; FIXME: Add some "global pattern" to wrap every case?
@@ -938,8 +925,7 @@ Otherwise, it defers to REST which is a list of branches of the form
        (t (error "Unknown pattern `%S'" upat)))))
    (t (error "Incorrect MATCH %S" (car matches)))))
 
-(def-edebug-spec
-  pcase-QPAT
+(def-edebug-spec pcase-QPAT
   ;; Cf. edebug spec for `backquote-form' in edebug.el.
   (&or ("," pcase-PAT)
        (pcase-QPAT [&rest [&not ","] pcase-QPAT]