From: Okamsn via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>
To: Stefan Monnier <monnier@iro.umontreal.ca>
Cc: 67611@debbugs.gnu.org, joaotavora@gmail.com
Subject: bug#67611: [PATCH] Add a Pcase pattern `cl-lambda` equivalent to `cl-destructuring-bind`
Date: Mon, 25 Dec 2023 21:30:07 +0000 [thread overview]
Message-ID: <30f1bf76-1cf1-493e-be4f-38e405d0ecf6@protonmail.com> (raw)
In-Reply-To: <jwvplzllrrm.fsf-monnier+emacs@gnu.org>
[-- Attachment #1: Type: text/plain, Size: 1542 bytes --]
Stefan Monnier wrote:
>> The attached patch adds the pattern `cl-lambda` for Pcase, which works
>> like `cl-destructuring-bind`. There are two differences with the lambda
>> lists:
>
> Hmm... I'm not sure mixing the CL destructuring patterns with the Pcase
> patterns (both of which are rather featureful and complex) will help
> their popularity.
>
> Beside that problem (which means I'm not very favorable to the
> addition), the name should be changed because "lambda" is misleading.
> It suggests this has to do with a function (I had to read the code to
> understand what this is doing).
>
>> The pattern is useful when one wants to combine the features of `pcase`
>> and `cl-destructuring-bind`, such combining the optional values with the
>> `pred` or `guard` patterns.
>
> Do you have examples uses?
>
> Maybe we could introduce a different Pcase pattern which covers those
> needs but stays closer to the Pcase pattern syntax?
>
>
> Stefan
>
Hello,
Because I wrote this patch with the thought that others might want it, I
don't have any nontrivial examples to share right now. The best example
I have for the use of the optional arguments is for the implementing of
the optional arguments, which isn't very convincing.
I've updated the patch to rename the pattern to `cl-arglist` and to
avoid creating intermediate variables using the `let` pattern, but I'm
fine with resting the discussion here until a stronger argument can be
made in favor of the patch.
Thank you.
[-- Attachment #2: v2-0001-Add-the-Pcase-pattern-cl-arglist-for-matching-a-C.patch --]
[-- Type: text/x-patch, Size: 38778 bytes --]
From e1752da863b44c93d139ca88bf8c7f6549229d18 Mon Sep 17 00:00:00 2001
From: Earl Hyatt <okamsn@protonmail.com>
Date: Sat, 25 Nov 2023 13:00:03 -0500
Subject: [PATCH v2] Add the Pcase pattern `cl-arglist' for matching a CL
argument list.
This pattern matches function argument lists as described in the Info
node `(cl)Argument Lists'.
* lisp/emacs-lisp/cl-macs.el (cl-arglist--pcase-macroexpander)
(cl-arglist, cl--pcase-arglist-list-get-var-groups)
(cl--pcase-cl-arglist-positional-pattern)
(cl--pcase-cl-arglist-plist-keys)
(cl--pcase-cl-arglist-&key-pattern)
(cl--pcase-cl-arglist-&aux-pattern):
Add pattern and supporting functions.
* test/lisp/emacs-lisp/pcase-tests.el:
(pcase-tests-cl-arglist-&whole-should-error)
(pcase-tests-cl-arglist-&whole)
(pcase-tests-cl-arglist-pos, pcase-tests-cl-arglist-pos-sub-patterns)
(pcase-tests-cl-arglist-&optional-should-error)
(pcase-tests-cl-arglist-&optional)
(pcase-tests-cl-arglist-&optional-sub-patterns)
(pcase-tests-cl-arglist-&rest-should-error)
(pcase-tests-cl-arglist-&rest-nonlist-cdr)
(pcase-tests-cl-arglist-&rest-with-&whole)
(pcase-tests-cl-arglist-&rest-only)
(pcase-tests-cl-arglist-&rest-after-&optional)
(pcase-tests-cl-arglist-&rest-sub-patterns)
(pcase-tests-cl-arglist-&key-should-error)
(pcase-tests-cl-arglist-&key-exact)
(pcase-tests-cl-arglist-&key-permissive)
(pcase-tests-cl-arglist-&key-not-first)
(pcase-tests-cl-arglist-&key-full-form)
(pcase-tests-cl-arglist-&key-sub-patterns)
(pcase-tests-cl-arglist-&aux-should-error)
(pcase-tests-cl-arglist-&aux)
(pcase-tests-cl-arglist-&aux-sub-patterns)
(pcase-tests-cl-arglist-all):
Add tests.
---
lisp/emacs-lisp/cl-macs.el | 343 ++++++++++++++++++
test/lisp/emacs-lisp/pcase-tests.el | 515 ++++++++++++++++++++++++++++
2 files changed, 858 insertions(+)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 7c207d372fc..0e10011a506 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3825,6 +3825,349 @@ cl-type
TYPE is a type descriptor as accepted by `cl-typep', which see."
`(pred (pcase--flip cl-typep ',type)))
+;;; Pcase lambda-list pattern
+
+;; This pattern is like `cl-destructuring-bind', but with `pcase'. We
+;; can't use `cl--do-arglist' for this, because `cl--do-arglist' uses
+;; `pop' to modify earlier variables while setting later ones, which
+;; doesn't seem to work with `pcase'.
+
+(define-error 'cl--pcase-cl-arglist-invalid-arg-list
+ "Invalid argument list used in `cl-arglist' pattern.")
+
+(defun cl--pcase-cl-arglist-var-groups (lambda-list)
+ "Return the alist of variable groups in LAMBDA-LIST.
+
+Lists are of the form
+`([&whole WHOLE-VAR] [POS-VARS] [&optional OPT-VARS] [&rest REST-VAR]
+[&key KEY-VARS] [&aux AUX-VARS])'."
+ (let ((whole-var) (processing-whole)
+ (pos-var)
+ (opt-var) (processing-opts)
+ (rest-var) (processing-rest) (dotted-rest-var)
+ (key-var) (processing-keys) (allow-other-keys)
+ (aux-var) (processing-auxs)
+ (remaining-list (cl-copy-list lambda-list)))
+
+ (when (not (proper-list-p remaining-list))
+ (cl-shiftf dotted-rest-var
+ (cdr (last remaining-list))
+ nil))
+
+ (cl-flet ((missing-after (cdr) (or (null cdr)
+ (memq (car cdr) cl--lambda-list-keywords)))
+ (stop-processing () (setq processing-whole nil
+ processing-opts nil
+ processing-rest nil
+ processing-keys nil
+ processing-auxs nil)))
+
+ (cl-loop
+ for (first . rest) on remaining-list
+ do
+ (pcase first
+ ('&whole
+ (if (or (missing-after rest)
+ whole-var pos-var opt-var
+ rest-var key-var allow-other-keys aux-var)
+ (signal 'cl--pcase-cl-arglist-invalid-arg-list (list lambda-list))
+ (stop-processing)
+ (setq processing-whole t)))
+
+ ('&optional
+ (if (or (missing-after rest)
+ opt-var rest-var key-var allow-other-keys aux-var)
+ (signal 'cl--pcase-cl-arglist-invalid-arg-list
+ (list lambda-list))
+ (stop-processing)
+ (setq processing-opts t)))
+
+ ((or '&rest '&body)
+ (if (or (missing-after rest)
+ rest-var key-var allow-other-keys aux-var
+ dotted-rest-var)
+ (signal 'cl--pcase-cl-arglist-invalid-arg-list
+ (list lambda-list))
+ (stop-processing)
+ (setq processing-rest t)))
+
+ ('&key
+ (if (or (missing-after rest)
+ key-var allow-other-keys aux-var
+ dotted-rest-var)
+ (signal 'cl--pcase-cl-arglist-invalid-arg-list
+ (list lambda-list))
+ (stop-processing)
+ (setq processing-keys t)))
+
+ ('&allow-other-keys
+ (if (or (not processing-keys)
+ allow-other-keys
+ dotted-rest-var)
+ (signal 'cl--pcase-cl-arglist-invalid-arg-list
+ (list lambda-list))
+ (stop-processing)
+ (setq allow-other-keys t)))
+
+ ('&aux
+ (if (or (missing-after rest)
+ aux-var
+ dotted-rest-var)
+ (signal 'cl--pcase-cl-arglist-invalid-arg-list
+ (list lambda-list))
+ (stop-processing)
+ (setq processing-auxs t)))
+
+ ((guard processing-whole)
+ (setq whole-var first
+ processing-whole nil))
+
+ ((guard processing-rest)
+ (setq rest-var first
+ processing-rest nil))
+
+ ((guard processing-opts)
+ (push first opt-var))
+
+ ((guard processing-keys)
+ (push first key-var))
+
+ ((guard processing-auxs)
+ (push first aux-var))
+
+ ('&environment
+ (signal 'cl--pcase-cl-arglist-invalid-arg-list
+ (list lambda-list)))
+
+ (_
+ (if (or opt-var rest-var key-var aux-var
+ allow-other-keys)
+ (signal 'cl--pcase-cl-arglist-invalid-arg-list
+ (list lambda-list))
+ (push first pos-var))))))
+
+ `((whole . ,whole-var)
+ (pos . ,(nreverse pos-var))
+ (opt . ,(nreverse opt-var))
+ (rest . ,(or dotted-rest-var rest-var))
+ (key . ,(nreverse key-var))
+ (allow-other-keys . ,allow-other-keys)
+ (aux . ,(nreverse aux-var)))))
+
+(defun cl--pcase-cl-arglist-positional-pattern (pos-vars opt-vars rest-var key-vars)
+ "Build a pattern for the positional, `&optional', and `&rest' variables.
+
+POS-VARS is the list of the positional variables. OPT-VARS is the list of
+the optional variables. REST-VAR is the `&rest' variable."
+ ;; A modified version of the back-quote pattern to better work with
+ ;; optional values.
+ (cond
+ (pos-vars `(and (pred consp)
+ (app car-safe ,(car pos-vars))
+ (app cdr-safe ,(cl--pcase-cl-arglist-positional-pattern
+ (cdr pos-vars) opt-vars
+ rest-var key-vars))))
+ (opt-vars (pcase-let (((or `(,var ,default ,supplied)
+ `(,var ,default)
+ `(,var)
+ var)
+ (car opt-vars)))
+ `(and (pred listp)
+ (app car-safe (or (and (pred null)
+ ,@(when supplied `((let ,supplied nil)))
+ ,@(when default `((let ,var ,default))))
+ ,(if supplied
+ `(and (let ,supplied t)
+ ,var)
+ var)))
+ (app cdr-safe ,(cl--pcase-cl-arglist-positional-pattern
+ nil (cdr opt-vars)
+ rest-var key-vars)))))
+ (rest-var rest-var)
+ ;; `pcase' allows `(,a ,b) to match (1 2 3), so we need to make
+ ;; sure there aren't more values left. However, if we are using
+ ;; `&key', then we allow more values.
+ (key-vars '_)
+ (t '(pred null))))
+
+(defun cl--pcase-cl-arglist-&key-pattern (key-vars allow-other-keys)
+ "Build a `pcase' pattern for the `&key' variables.
+
+KEY-VARS are the forms of the key variables. ALLOW-OTHER-KEYS is
+whether `&allow-other-keys' was used. PLIST-VAR is the variable
+holding the property list."
+ ;; If we aren't checking whether all keys in EXPVAL were given,
+ ;; then we can use simpler patterns since we don't need to store the
+ ;; value of the key.
+ (cl-flet ((get-var-data (var-form)
+ (pcase-let (((or (or `((,key ,var) ,default ,supplied)
+ `((,key ,var) ,default)
+ `((,key ,var)))
+ (and (or `(,var ,default ,supplied)
+ `(,var ,default)
+ `(,var)
+ (and (pred symbolp)
+ var))
+ ;; Strip a leading underscore, since it
+ ;; only means that this argument is
+ ;; unused, but shouldn't affect the
+ ;; key's name (bug#12367).
+ (let key (intern
+ (format ":%s"
+ (let ((name (symbol-name var)))
+ (if (eq ?_ (aref name 0))
+ (substring name 1)
+ name)))))))
+ var-form))
+ (list key var default supplied))))
+ (if allow-other-keys
+ `(and ,@(mapcar (lambda (var-form)
+ (pcase-let ((`(,key ,var ,default ,supplied) (get-var-data var-form))
+ (key-found (gensym "key-found"))
+ (plist (gensym "plist")))
+ (cond (supplied
+ `(app (lambda (,plist)
+ (let ((,key-found (plist-member ,plist ,key)))
+ (if ,key-found
+ (cons t (cadr ,plist))
+ (cons nil ,default))))
+ (,'\` ((,'\, ,supplied) . (,'\, ,var)))))
+ (default
+ `(app (lambda (,plist)
+ (let ((,key-found (plist-member ,plist ,key)))
+ (if ,key-found
+ (cadr ,plist)
+ ,default)))
+ ,var))
+ (t
+ `(app (pcase--flip plist-get ,key)
+ ,var)))))
+ key-vars))
+ ;; If we are checking whether there are no other keys in EXPVAL,
+ ;; then we use a single function for extracting the associated
+ ;; values and performing the check, whose output we match against
+ ;; a list of patterns.
+ (let ((res (gensym "res"))
+ (keys (gensym "keys"))
+ (plist (gensym "plist"))
+ (pats nil))
+ `(app (lambda (,plist)
+ (let ((,res nil)
+ (,keys nil))
+ ,@(cl-loop
+ for (key var default supplied) in (mapcar #'get-var-data key-vars)
+ collect (macroexp-let2* ((keyval key))
+ nil
+ `(progn
+ (push ,keyval ,keys)
+ ,(cond
+ (supplied
+ (push supplied pats)
+ (push var pats)
+ (cl-once-only ((key-found `(plist-member ,plist ,keyval)))
+ `(if ,key-found
+ (progn
+ (push t ,res)
+ (push (cadr ,key-found) ,res))
+ (push nil ,res)
+ (push ,default ,res))))
+ (default
+ (push var pats)
+ (cl-once-only ((key-found `(plist-member ,plist ,keyval)))
+ `(if ,key-found
+ (push (cadr ,key-found) ,res)
+ (push ,default ,res))))
+ (t
+ (push var pats)
+ `(push (plist-get ,plist ,keyval)
+ ,res))))))
+ (push (or (plist-get ,plist :allow-other-keys)
+ (cl-loop for (key _val) on ,plist by #'cddr
+ always (memq key ,keys)))
+ ,res)
+ ;; Reverse in case a latter pattern use a variable
+ ;; from an earlier pattern.
+ (nreverse ,res)))
+ (,'\` ,(cl-loop for pat in (reverse (cons '(pred (not null))
+ pats))
+ collect `(,'\, ,pat))))))))
+
+(defun cl--pcase-cl-arglist-&aux-pattern (aux-vars)
+ "Build `pcase' pattern for `&aux' variables.
+
+AUX-VARS is the list of bindings."
+ `(and ,@(cl-loop for bind in aux-vars
+ collect (pcase-let (((or `(,var ,val)
+ `(,var)
+ var)
+ bind))
+ `(let ,var ,val)))))
+
+;;;###autoload
+(pcase-defmacro cl-arglist (arglist)
+ "Match a CL argument list, as in `cl-defun' and `cl-defmacro'.
+
+See the Info node `(cl)Argument Lists'.
+
+This pattern does not support `&environment'.
+
+`&key' will fail to match if there are more keys in the plist
+then specified, unless `&allow-other-keys' is given or unless the
+plist associates the key `:allow-other-keys' with a non-nil
+value. Unlike `cl-destructuring-bind', this pattern does not
+signal an error if there are unmatched keys in the plist.
+
+Unlike the back-quote pattern, the pattern will fail to match if the
+non-optional part of ARGLIST is shorter than EXPVAL.
+
+For this `pcase' pattern, the variables in ARGLIST can
+themselves be `pcase' patterns, instead of just symbols as in a
+normal CL lambda list. However, argument-list constructs like
+`&optional', `&key', and `&aux' use sub-lists to specify default
+values and other features. For example,
+
+ (cl-arglist (&optional (opt1 default1 opt1-supplied)))
+
+Therefore, to avoid ambiguity, the use of sub-patterns can only
+be done within the sub-list for those constructs. For example,
+
+ (cl-arglist (&optional ((and opt1 (guard (listp opt1)))
+ nil)))
+
+For similar reasons, the cdr of a dotted list (as opposed to the
+element following `&rest') for the remainder of a list cannot be
+a sub-pattern."
+ (let* ((groups (cl--pcase-cl-arglist-var-groups arglist))
+ (whole-var (alist-get 'whole groups))
+ (pos-vars (alist-get 'pos groups))
+ (opt-vars (alist-get 'opt groups))
+ (rest-var (alist-get 'rest groups))
+ (key-vars (alist-get 'key groups))
+ (allow-other-keys (alist-get 'allow-other-keys groups))
+ (aux-vars (alist-get 'aux groups)))
+ (remq nil
+ `(and (pred listp)
+ ,(when whole-var
+ whole-var)
+ ,(when (or pos-vars opt-vars rest-var)
+ (cl--pcase-cl-arglist-positional-pattern
+ pos-vars opt-vars
+ rest-var key-vars))
+ ,(when key-vars
+ (cond
+ (rest-var `(app (lambda (_) ,rest-var)
+ ,(cl--pcase-cl-arglist-&key-pattern
+ key-vars allow-other-keys)))
+ ((or pos-vars opt-vars)
+ `(app (nthcdr ,(+ (length pos-vars)
+ (length opt-vars)))
+ ,(cl--pcase-cl-arglist-&key-pattern
+ key-vars allow-other-keys)))
+ (t (cl--pcase-cl-arglist-&key-pattern
+ key-vars allow-other-keys))))
+ ,(when aux-vars
+ (cl--pcase-cl-arglist-&aux-pattern aux-vars))))))
+
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index 799e8d36647..108e4b96d04 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -160,4 +160,519 @@ pcase-tests-setq
(should-error (pcase-setq a)
:type '(wrong-number-of-arguments)))
+;;;; Tests for the `cl-arglist' `pcase' pattern.
+
+(ert-deftest pcase-tests-cl-arglist-&whole-should-error ()
+ "`&whole' must come first if given, and must be followed by a patter."
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&whole))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (a b &whole c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&rest a &whole c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&key a &whole c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&aux (a 1) &whole c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&optional (a 1) &whole c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&whole whole1 &whole whole2))
+ (list whole1 whole2)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&whole ()
+ "`&whole' can be a `pcase' pattern."
+ (should (equal (list (list 1 2 3) 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (&whole whole a b c))
+ (list whole a b c)))))
+
+ (should (equal (list 1 2 3 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (&whole `(,a0 ,b0 ,c0) a b c))
+ (list a0 b0 c0 a b c))))))
+
+(ert-deftest pcase-tests-cl-arglist-pos ()
+ "Positional variables must match the length of EXPVAL."
+ (should (equal (list 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (a b c))
+ (list a b c)))))
+
+ (should (equal nil
+ (pcase (list (list 1))
+ ((cl-arglist (a b))
+ (list a b)))))
+
+ (should (equal nil
+ (pcase (list (list 1 2 3))
+ ((cl-arglist (a b))
+ (list a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-pos-sub-patterns ()
+ (should (equal (list 1 2 3 4)
+ (pcase (list 1 2 (list 3 4))
+ ((cl-arglist (a b (cl-arglist (c d))))
+ (list a b c d)))))
+
+ (should (equal (list 1 2)
+ (pcase (list (list 1 2))
+ ((cl-arglist (`(,a ,b)))
+ (list a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-&optional-should-error ()
+ "`&optional' cannot be used after `&optional', `&rest', `&key', and `&aux'."
+ (should-error (equal (list 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (&rest a &optional b c))
+ (list a b c))))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&body a &optional b c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&key a &optional b c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&allow-other-keys &optional b c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&aux (a 1) &optional b c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&optional a &optional b c))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&optional ()
+ (should (equal (list 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (a b &optional c))
+ (list a b c)))))
+
+ (should (equal (list 1 2 nil)
+ (pcase (list 1 2)
+ ((cl-arglist (a b &optional c))
+ (list a b c)))))
+
+ (should (equal (list 1 2 13)
+ (pcase (list 1 2)
+ ((cl-arglist (a b &optional (c 13)))
+ (list a b c)))))
+
+ (should (equal (list 1 2 13 nil)
+ (pcase (list 1 2)
+ ((cl-arglist (a b &optional (c 13 c-supplied)))
+ (list a b c c-supplied)))))
+
+ (should (equal (list 1 2 3 t)
+ (pcase (list 1 2 3)
+ ((cl-arglist (a b &optional (c 13 c-supplied)))
+ (list a b c c-supplied))))))
+
+(ert-deftest pcase-tests-cl-arglist-&optional-sub-patterns ()
+ "Test using sub-patterns in `cl-arglist' pattern.
+Sub-patterns must be contained within a sub-list, since a sub-list
+also provides a default value."
+ (should-error (pcase (list 1 2 (list 3 4))
+ ((cl-arglist (a b &optional `(,c ,d)))
+ (list a b c d))))
+
+ (should (equal (list 1 2 33)
+ (pcase (list 1 2)
+ ((cl-arglist (a b &optional ((and opt1
+ (guard (numberp opt1)))
+ 33)))
+ (list a b opt1)))))
+
+ (should (equal nil
+ (pcase (list 1 2 'not-num)
+ ((cl-arglist (a b &optional ((and opt1
+ (guard (numberp opt1)))
+ 33)))
+ (list a b opt1)))))
+
+ (should (equal nil
+ (pcase (list 1 2 nil)
+ ((cl-arglist (a b &optional ((and opt1
+ (guard (numberp opt1)))
+ 'not-num)))
+ (list a b opt1)))))
+
+ (should (equal (list 1 2 3 4)
+ (pcase (list 1 2 (list 3 4))
+ ((cl-arglist (a b &optional (`(,c ,d))))
+ (list a b c d)))))
+
+ (should (equal (list 1 2 nil nil)
+ (pcase (list 1 2)
+ ((cl-arglist (a b &optional (`(,c ,d))))
+ (list a b c d)))))
+
+ (should (equal (list 1 2 13 14)
+ (pcase (list 1 2)
+ ((cl-arglist (a b &optional (`(,c ,d) (list 13 14))))
+ (list a b c d)))))
+
+ (should (equal (list 1 2 13 14)
+ (pcase (list 1 2)
+ ((cl-arglist ( a b
+ &optional ((cl-arglist (c &optional (d 14)))
+ (list 13))))
+ (list a b c d)))))
+
+ (should (equal (list 1 2 13 14 nil)
+ (pcase (list 1 2)
+ ((cl-arglist (a b &optional (`(,c ,d) (list 13 14) cd-supplied)))
+ (list a b c d cd-supplied)))))
+
+ (should (equal (list 1 2 13 14 nil t nil)
+ (pcase (list 1 2)
+ ((cl-arglist ( a b
+ &optional
+ ((cl-arglist (&optional (c 27 c-sub-sup)
+ (d 14 d-sub-sup)))
+ (list 13)
+ cd-supplied)))
+ (list a b c d cd-supplied c-sub-sup d-sub-sup))))))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-should-error ()
+ "`&rest' (`&body', `.') cannot be used after `&rest', `&body', `&key',and `&aux'."
+ (should-error (equal (list 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (&rest a &rest b))
+ (list a b c))))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (equal (list 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (&body a &body b))
+ (list a b c))))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (equal (list 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (&body a . b))
+ (list a b c))))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&body a &rest b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&rest a &body b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&key a &rest b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&key a &body b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&key a . b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&allow-other-keys &rest b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&allow-other-keys &body b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&allow-other-keys . b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&aux (a 1) &rest b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&aux (a 1) &body b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list 1 2 3)
+ ((cl-arglist (&aux (a 1) . b))
+ (list a b c)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-nonlist-cdr ()
+ (should (equal (list 1 2)
+ (pcase (cons 1 2)
+ ((cl-arglist (a &rest b))
+ (list a b)))))
+
+ (should (equal (list 1 2)
+ (pcase (cons 1 2)
+ ((cl-arglist (a &body b))
+ (list a b)))))
+
+ (should (equal (list 1 2)
+ (pcase (cons 1 2)
+ ((cl-arglist (a . b))
+ (list a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-with-&whole ()
+ (should (equal (list (cons 1 2) 1 2)
+ (pcase (cons 1 2)
+ ((cl-arglist (&whole whole a &rest b))
+ (list whole a b)))))
+
+ (should (equal (list (cons 1 2) 1 2)
+ (pcase (cons 1 2)
+ ((cl-arglist (&whole whole a &body b))
+ (list whole a b)))))
+
+ (should (equal (list (cons 1 2) 1 2)
+ (pcase (cons 1 2)
+ ((cl-arglist (&whole whole a . b))
+ (list whole a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-only ()
+ "Using only `&rest' should work like `&whole'."
+ (should (equal (list (list 1 2))
+ (pcase (list 1 2)
+ ((cl-arglist (&rest a))
+ (list a)))))
+
+ (should (equal (list (cons 1 2))
+ (pcase (cons 1 2)
+ ((cl-arglist (&body a))
+ (list a))))))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-after-&optional ()
+ (should (equal (list 1 2 3 (list 4 5))
+ (pcase (list 1 2 3 4 5)
+ ((cl-arglist (&optional a b c &rest d))
+ (list a b c d)))))
+
+ (should (equal (list 1 2 3 (list 4 5))
+ (pcase (list 1 2 3 4 5)
+ ((cl-arglist (&optional a b c &body d))
+ (list a b c d)))))
+
+ (should (equal (list 1 2 3 (list 4 5))
+ (pcase (list 1 2 3 4 5)
+ ((cl-arglist (&optional a b c . d))
+ (list a b c d))))))
+
+(ert-deftest pcase-tests-cl-arglist-&rest-sub-patterns ()
+ ;; We can't do (a . `(,b . ,c)), so we don't test that.
+ (should (equal (list 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (a &rest (cl-arglist (b c))))
+ (list a b c)))))
+
+ (should (equal (list 1 2 3)
+ (pcase (list 1 2 3)
+ ((cl-arglist (a &body `(,b ,c)))
+ (list a b c))))))
+
+(ert-deftest pcase-tests-cl-arglist-&key-should-error ()
+ "`&key' cannot be used after `&key', `&allow-other-keys', and `&aux'."
+ (should-error (pcase (list :a 1 :b 2)
+ ((cl-arglist (&key a &key b))
+ (list a b)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list :a 1 :b 2)
+ ((cl-arglist (&aux (a 1) &key b))
+ (list a b)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list)
+
+ (should-error (pcase (list :a 1 :b 2)
+ ((cl-arglist (&allow-other-keys &key b))
+ (list a b)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&key-exact ()
+ "`&key' doesn't match unspecified keys unless `&allow-other-keys' or `:allow-other-keys' is given."
+ (should (equal (list 1 2)
+ (pcase (list :a 1 :b 2)
+ ((cl-arglist (&key a b))
+ (list a b)))))
+
+ (should (equal nil
+ (pcase (list :a 1 :b 2 :c 3)
+ ((cl-arglist (&key a b))
+ (list a b)))))
+
+ (should (equal (list 1 2 nil)
+ (pcase (list :a 1 :b 2)
+ ((cl-arglist (&key a b c))
+ (list a b c))))))
+
+(ert-deftest pcase-tests-cl-arglist-&key-permissive ()
+ "`&key' doesn't match unspecified keys unless `&allow-other-keys' or `:allow-other-keys' is given."
+ (should (equal (list 1 2)
+ (pcase (list :a 1 :b 2 :c 3)
+ ((cl-arglist (&key a b &allow-other-keys))
+ (list a b)))))
+
+ (should (equal (list 1 2)
+ (pcase (list :a 1 :b 2 :c 3 :allow-other-keys t)
+ ((cl-arglist (&key a b))
+ (list a b))))))
+
+(ert-deftest pcase-tests-cl-arglist-&key-not-first ()
+ "The plist should be after positional values and equal to `&rest'."
+ (should (equal (list 1 2 3 11 22)
+ (pcase (list 1 2 3 :k1 11 :k2 22)
+ ((cl-arglist (a b c &key k1 k2))
+ (list a b c k1 k2)))))
+
+ (should (equal (list 1 2 3 (list :k1 11 :k2 22) 11 22)
+ (pcase (list 1 2 3 :k1 11 :k2 22)
+ ((cl-arglist (a b c &rest r1 &key k1 k2))
+ (list a b c r1 k1 k2))))))
+
+(ert-deftest pcase-tests-cl-arglist-&key-full-form ()
+ (should (equal (list 1 2)
+ (pcase (list :a 1 :b 2)
+ ((cl-arglist (&key a (b 13)))
+ (list a b)))))
+
+ (should (equal (list 1 13)
+ (pcase (list :a 1)
+ ((cl-arglist (&key a (b 13)))
+ (list a b)))))
+
+ (should (equal (list 1 13 nil)
+ (pcase (list :a 1)
+ ((cl-arglist (&key a (b 13 b-supplied)))
+ (list a b b-supplied)))))
+
+ (should (equal (list 1 2 t)
+ (pcase (list :a 1 :b 2)
+ ((cl-arglist (&key a (b 13 b-supplied)))
+ (list a b b-supplied)))))
+
+ (should (equal (list 1 2 t)
+ (pcase (list :a 1 :bat 2)
+ ((cl-arglist (&key a ((:bat b) 13 b-supplied)))
+ (list a b b-supplied)))))
+
+ (should (equal (list 1 2 t)
+ (let ((key :bat))
+ (pcase (list :a 1 :bat 2)
+ ((cl-arglist (&key a ((key b) 13 b-supplied)))
+ (list a b b-supplied)))))))
+
+(ert-deftest pcase-tests-cl-arglist-&key-sub-patterns ()
+ (should (equal '(1 2 (:c 77 :e should-ignore) nil 77 t 99 nil)
+ (pcase '(:ab (1 2))
+ ((cl-arglist (&key
+ ((:ab `(,a ,b)))
+ ((:cd (cl-arglist ( &whole cd
+ &key
+ (c 88 c-supp)
+ ((:d d) 99 d-supp)
+ &allow-other-keys)))
+ (list :c 77 :e 'should-ignore)
+ cd-supp)))
+ (list a b cd cd-supp c c-supp d d-supp)))))
+
+ (should (equal '( 1 2 (:c 77 :e should-ignore :allow-other-keys t) nil
+ 77 t 99 nil)
+ (pcase '(:ab (1 2))
+ ((cl-arglist (&key
+ ((:ab `(,a ,b)))
+ ((:cd (cl-arglist ( &whole cd
+ &key
+ (c 88 c-supp)
+ ((:d d) 99 d-supp))))
+ (list :c 77 :e 'should-ignore
+ :allow-other-keys t)
+ cd-supp)))
+ (list a b cd cd-supp c c-supp d d-supp)))))
+
+ (should (equal nil
+ (pcase '(:ab (1 2))
+ ((cl-arglist (&key
+ ((:ab `(,a ,b)))
+ ((:cd (cl-arglist ( &whole cd
+ &key
+ (c 88 c-supp)
+ ((:d d) 99 d-supp))))
+ (list :c 77 :e 'should-fail)
+ cd-supp)))
+ (list a b cd cd-supp c c-supp d d-supp))))))
+
+(ert-deftest pcase-tests-cl-arglist-&aux-should-error ()
+ "`&aux' cannot be used after `&aux'."
+ (should-error (pcase nil
+ ((cl-arglist (&aux a &aux b))
+ (list a b)))
+ :type 'cl--pcase-cl-arglist-invalid-arg-list))
+
+(ert-deftest pcase-tests-cl-arglist-&aux ()
+ (should (equal (list 1 2 nil nil)
+ (pcase nil
+ ((cl-arglist (&aux (a 1) (b 2) (c) d))
+ (list a b c d)))))
+
+ (should (equal (list 0 1 2 nil nil)
+ (pcase (list 0)
+ ((cl-arglist (z0 &aux (a 1) (b 2) (c) d))
+ (list z0 a b c d))))))
+
+(ert-deftest pcase-tests-cl-arglist-&aux-sub-patterns ()
+ (should (equal (list 1 2)
+ (pcase nil
+ ((cl-arglist (&aux (`(,a ,b) (list 1 2))))
+ (list a b ))))))
+
+(ert-deftest pcase-tests-cl-arglist-all ()
+ (should (equal '(1 2 3 4 5 (:k1 111 :k2 222) 111 222 333 444)
+ (pcase (list 1 2 3 4 5 :k1 111 :k2 222)
+ ((cl-arglist ( a b c
+ &optional d e
+ &rest r
+ &key k1 k2
+ &aux (x1 333) (x2 444)))
+ (list a b c d e r k1 k2 x1 x2))))))
+
;;; pcase-tests.el ends here.
--
2.34.1
next prev parent reply other threads:[~2023-12-25 21:30 UTC|newest]
Thread overview: 25+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-12-03 20:33 bug#67611: [PATCH] Add a Pcase pattern `cl-lambda` equivalent to `cl-destructuring-bind` Okamsn via Bug reports for GNU Emacs, the Swiss army knife of text editors
2023-12-04 19:08 ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2023-12-05 2:42 ` Okamsn via Bug reports for GNU Emacs, the Swiss army knife of text editors
2023-12-05 9:26 ` João Távora
2023-12-05 9:21 ` João Távora
2023-12-25 21:30 ` Okamsn via Bug reports for GNU Emacs, the Swiss army knife of text editors [this message]
2024-01-11 21:12 ` Stefan Kangas
2024-01-11 21:56 ` João Távora
2024-01-11 22:13 ` Stefan Kangas
2024-01-11 22:46 ` João Távora
2024-01-12 0:55 ` Okamsn via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-01-13 6:38 ` Stefan Kangas
2024-01-12 3:04 ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-01-12 10:46 ` João Távora
2024-01-12 15:38 ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-01-12 16:56 ` João Távora
2024-01-13 6:58 ` Stefan Kangas
2024-01-14 3:08 ` Richard Stallman
2024-01-14 3:12 ` João Távora
2024-01-17 3:29 ` Richard Stallman
2024-01-17 9:12 ` João Távora
2024-02-08 3:49 ` Richard Stallman
2024-02-08 13:41 ` João Távora
2024-02-11 3:28 ` Richard Stallman
2024-02-12 15:25 ` João Távora
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=30f1bf76-1cf1-493e-be4f-38e405d0ecf6@protonmail.com \
--to=bug-gnu-emacs@gnu.org \
--cc=67611@debbugs.gnu.org \
--cc=joaotavora@gmail.com \
--cc=monnier@iro.umontreal.ca \
--cc=okamsn@protonmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.