1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 06:20:55 -08:00

* lisp/emacs-lisp/pcase.el: Add support for not to pred

(pcase--split-pred, pcase--funcall): Adjust for `not`.
(pcase--get-macroexpander): New function.
(pcase--edebug-match-macro, pcase--make-docstring)
(pcase--macroexpand): Use it.

* lisp/emacs-lisp/radix-tree.el (radix-tree-leaf): Use it!

* doc/lispref/control.texi (The @code{pcase} macro): Document it.

* lisp/emacs-lisp/ert.el (ert--explain-equal-rec): Remove redundant test.
This commit is contained in:
Stefan Monnier 2021-01-16 10:15:47 -05:00
parent df34ed8cbf
commit 0ab56a4e93
6 changed files with 56 additions and 16 deletions

View file

@ -39,10 +39,10 @@
;; - along these lines, provide patterns to match CL structs.
;; - provide something like (setq VAR) so a var can be set rather than
;; let-bound.
;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
;; this :-()
;; - provide a way to fallthrough to subsequent cases
;; (e.g. Like Racket's (=> ID).
;; - try and be more clever to reduce the size of the decision tree, and
;; to reduce the number of leaves that need to be turned into function:
;; to reduce the number of leaves that need to be turned into functions:
;; - first, do the tests shared by all remaining branches (it will have
;; to be performed anyway, so better do it first so it's shared).
;; - then choose the test that discriminates more (?).
@ -97,11 +97,15 @@
(declare-function get-edebug-spec "edebug" (symbol))
(declare-function edebug-match "edebug" (cursor specs))
(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 (get s 'pcase-macroexpander)))
(let ((m (pcase--get-macroexpander s)))
(when (and m (get-edebug-spec m))
(push (cons (symbol-name s) (get-edebug-spec m))
specs)))))
@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms:
If a SYMBOL is used twice in the same pattern
the second occurrence becomes an `eq'uality test.
(pred FUN) matches if FUN called on EXPVAL returns non-nil.
(pred (not FUN)) matches if FUN called on EXPVAL returns nil.
(app FUN PAT) matches if FUN called on EXPVAL matches PAT.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
(let PAT EXPR) matches if EXPR matches PAT.
@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples."
(let (more)
;; Collect all the extensions.
(mapatoms (lambda (symbol)
(let ((me (get symbol 'pcase-macroexpander)))
(let ((me (pcase--get-macroexpander symbol)))
(when me
(push (cons symbol me)
more)))))
@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'.
((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
(t
(let* ((expander (get head 'pcase-macroexpander))
(let* ((expander (pcase--get-macroexpander head))
(npat (if expander (apply expander (cdr pat)))))
(if (null npat)
(error (if expander
@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form:
'(:pcase--succeed . nil))))
(defun pcase--split-pred (vars upat pat)
"Indicate the overlap or mutual-exclusion between UPAT and PAT.
More specifically retuns a pair (A . B) where A indicates whether PAT
can match when UPAT has matched, and B does the same for the case
where UPAT failed to match.
A and B can be one of:
- nil if we don't know
- `:pcase--fail' if UPAT match's result implies that PAT can't match
- `:pcase--succeed' if UPAT match's result implies that PAT matches"
(let (test)
(cond
((and (equal upat pat)
@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form:
;; and catch at least the easy cases such as (bug#14773).
(not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
'(:pcase--succeed . :pcase--fail))
;; In case UPAT is of the form (pred (not PRED))
((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
(let* ((test (cadr (cadr upat)))
(res (pcase--split-pred vars `(pred ,test) pat)))
(cons (cdr res) (car res))))
;; In case PAT is of the form (pred (not PRED))
((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
(let* ((test (cadr (cadr pat)))
(res (pcase--split-pred vars upat `(pred ,test)))
(reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail)
((eq x :pcase--fail) :pcase--succeed)))))
(cons (funcall reverse (car res))
(funcall reverse (cdr res)))))
((and (eq 'pred (car upat))
(let ((otherpred
(cond ((eq 'pred (car-safe pat)) (cadr pat))
@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form:
(defun pcase--funcall (fun arg vars)
"Build a function call to FUN with arg ARG."
(if (symbolp fun)
`(,fun ,arg)
(cond
((symbolp fun) `(,fun ,arg))
((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars)))
(t
(let* (;; `env' is an upper bound on the bindings we need.
(env (mapcar (lambda (x) (list (car x) (cdr x)))
(macroexp--fgrep vars fun)))
@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form:
;; Let's not replace `vars' in `fun' since it's
;; too difficult to do it right, instead just
;; let-bind `vars' around `fun'.
`(let* ,env ,call)))))
`(let* ,env ,call))))))
(defun pcase--eval (exp vars)
"Build an expression that will evaluate EXP."