From c7b35ea3060b90ed68a933eed29e85dd2d567e3e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 12 Feb 2021 12:17:40 -0500 Subject: [PATCH] * 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 569545d83f1..693d0e0630a 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 228b773cb27..fe626fec7ec 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 04a4829c5e6..782299454ea 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 ¬)) cursor specs) ;; If any specs match, then fail diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 7a88bdf8de5..d6c96c1ec82 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 [¬ ","] pcase-QPAT] -- 2.39.2