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

[Stefan Monnier]

branch: master
commit c7b35ea3060b90ed68a933eed29e85dd2d567e3e
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * 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.
---
 doc/lispref/edebug.texi   | 11 +++++++++++
 etc/NEWS                  | 15 +++++++++------
 lisp/emacs-lisp/edebug.el | 17 +++++++++++++++++
 lisp/emacs-lisp/pcase.el  | 40 +++++++++++++---------------------------
 4 files changed, 50 insertions(+), 33 deletions(-)

diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 569545d..693d0e0 100644
--- 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 228b773..fe626fe 100644
--- 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 04a4829..7822994 100644
--- 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 7a88bdf..d6c96c1 100644
--- 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]