From 2fce5eb9bed698160e072a978f388bef4350c934 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 8 Jul 2024 01:56:16 +0000 Subject: [PATCH] (GitHub Action) Add `substream` and `stream` commands, `&seq` destructuring, and missing tests. (#199) This commit was copied from the master branch. Commit: 1c2a2164f24174a87194649f0286e0432594c84d Author: okamsn <28612288+okamsn@users.noreply.github.com> Date: 2024-07-08 01:56:02 +0000 Add `substream` and `stream` commands, `&seq` destructuring, and missing tests. (#199) - Add `substream` and `stream` commands. - Add `stream.el` to the dependencies. - Update Org documentation. - Add tests. - Add `&seq` destructuring for values and places. The substreams should only be destructured using `&seq`. - Add tests. - Update Org documentation. - Define an error for destructuring substreams with `&seq`. - Disable behavior of optional destructured values until we decide how that should work. See issue #198. - Add missing array tests along with the new `&seq` tests. - Convert some tests to new macros `loopy-def-pcase-test`, `loopy-def-pcase-test3`, and `loopy-def-loopy-ref-test`. - Use caching for `loopy--get-var-groups`. - Make sure `loopy--pcase-destructure-for-iteration` returns a list of symbols without duplication. - For extra safety deduplicate the returned variable list in `loopy--destructure-for-iteration`. Co-authored-by: okamsn --- doc/loopy-doc.org | 149 ++- loopy-commands.el | 63 +- loopy-destructure.el | 912 ++++++++++++------ loopy-iter.el | 4 +- loopy-misc.el | 12 + loopy-pkg.el | 3 +- loopy-vars.el | 4 + loopy.el | 2 +- tests/misc-tests.el | 2106 ++++++++++++++++++++++++++++-------------- tests/tests.el | 172 +++- 10 files changed, 2431 insertions(+), 996 deletions(-) diff --git a/doc/loopy-doc.org b/doc/loopy-doc.org index e6abed8c1..c7c5dc4b6 100644 --- a/doc/loopy-doc.org +++ b/doc/loopy-doc.org @@ -721,6 +721,7 @@ indirection. (numbers i :from 0 :to 3)) #+end_src +#+cindex: keyword evaluation Unlike ~cl-loop~ in some cases, in Loopy, the values passed as keyword arguments are evaluated only once. For example, the command =(list i some-list :by (get-function))= evaluates ~(get-function)~ only once. It does not evaluate it @@ -832,7 +833,9 @@ as the =VAR= argument of a loop command. Loopy supports destructuring lists and arrays (which includes strings and vectors). - To destructure lists, use a list, as in =(a b c)=. - To destructure arrays, use a vector, as in =[a b c]=. - +- To destructure sequences generically using =seq.el= (mainly via ~seq-elt~ and + ~seq-drop~), use a vector or a list whose first element is =&seq=, as in + =[&seq a b c]= and =(&seq a b c)=. This sequence of symbols can be shorter than the destructured sequence, /but not longer/. If shorter, the unassigned elements of the destructured sequence are @@ -891,8 +894,7 @@ In more detail, the elements of the destructuring sequence can be: - A positional variable which will be bound to the corresponding element in the sequence. These variables can themselves be sequences, but must be of the - correct type. Unlike ~seq-let~, Loopy does not currently have a generic - syntax for sequences. + correct type. #+begin_src emacs-lisp ;; ((1 2 3) (4 5 6)) @@ -923,9 +925,9 @@ In more detail, the elements of the destructuring sequence can be: #+end_src #+cindex: &whole -- The symbol =&whole=: If =&whole= is the first element in the sequence, then - the second element of the sequence names a variable that holds the entire - value of what is destructured. +- The symbol =&whole=: If =&whole= is the first element in the sequence (or the + second element if =&seq= is the first), then the following element of the + sequence names a variable that holds the entire value of what is destructured. This is the same as when used in a CL ~lambda~ list. @@ -952,7 +954,7 @@ In more detail, the elements of the destructuring sequence can be: When used after optional values, the =&rest= value is the subsequence starting at the index after any possible optional values, even when those optional - values are not actually present. If the sequence is not long enough, than the + values are not actually present. If the sequence is not long enough, then the sub-sequence is empty. #+begin_src emacs-lisp @@ -1005,11 +1007,11 @@ In more detail, the elements of the destructuring sequence can be: #+end_src #+cindex: &optional -- The symbol =&optional=: A variable named after =&optional= is optional. If - the list is not long enough to bind the variable, then the variable is bound - to ~nil~ or, if specified, a default value. Additionally, one may bind a - variable to record whether the list was long enough to contain the optional - value. +- The symbol =&optional=: A variable named after =&optional= is bound if the + sequence is long enough to have a value at that position. If the sequence is + not long enough, then the variable is bound to ~nil~ or, if specified, a + default value. Additionally, one may bind a variable to record whether the + sequence was long enough to contain the optional value. As in a CL ~lambda~ list, the variable has the one of the following forms: @@ -1062,7 +1064,7 @@ In more detail, the elements of the destructuring sequence can be: into keys whose values will be sought using ~plist-get~, which returns ~nil~ if the key isn't found in the list. - Currently, only lists support this destructuring. + Only lists support this destructuring. #+begin_src emacs-lisp ;; => ((1 2 nil) (4 5 nil)) @@ -1153,7 +1155,7 @@ In more detail, the elements of the destructuring sequence can be: Like in =cl-lib=, if, after searching for the other keys, there remains an unmatched key in the destructured value, an error is signaled unless =&allow-other-keys= is also used, or unless the key =:allow-other-keys= is - associated with a non-nil value in the property list, even when using =&rest=. + associated with a non-nil value in the property list. #+begin_src emacs-lisp ;; Error due to presence of `:k3': @@ -1170,8 +1172,8 @@ In more detail, the elements of the destructuring sequence can be: #+end_src #+cindex: &map -- The symbol =&map=: Variables after =&map= are bound similar to ~map-let~ from - the library =map.el=. =&map= works similarly to =&key=, but has a few +- The symbol =&map=: Variables after =&map= are bound similarly to ~map-let~ + from the library =map.el=. =&map= works similarly to =&key=, but has a few important differences: 1. Maps are more generic than property lists ("plists"). A "map" is a generic @@ -1198,9 +1200,8 @@ In more detail, the elements of the destructuring sequence can be: - a symbol =VAR= - When specifying =KEY=, =VAR= can be a sequence to perform further - destructuring. When =KEY= is not given, then the key is the symbol =VAR=, as - in ~(quote VAR)~. + When =KEY= is not given, then the key is the symbol =VAR=, as in ~(quote + VAR)~. Unlike with =&key=, it is not prepended with a colon. #+begin_src emacs-lisp ;; => ((1 2 3 4 27)) @@ -1249,7 +1250,7 @@ In more detail, the elements of the destructuring sequence can be: #+end_src - The symbol =&aux=: Variables named after =&aux= are bound to the given values. - Like in CL Lib, =&aux= must come last in the list. + Like in CL Lib, =&aux= must come last in the sequence. #+begin_src emacs-lisp ;; => (7 7 7) @@ -1258,6 +1259,24 @@ In more detail, the elements of the destructuring sequence can be: (finally-return coll)) #+end_src +- The symbol =&seq=: If the first symbol in the sequence is =&seq=, then the + sequence will be destructured as a generic sequence using the generic-sequence + library =seq.el=. Specifically, destructuring is similar to using ~seq-elt~ + and ~seq-drop~. This form is less efficient than destructuring a sequence as + an array or as a list, when applicable. + + Sequences destructured using =&seq= can still use =&whole=, =&optional=, + =&rest=, and =&map=. However, lists destructured using =&seq= cannot be + destructured using =&key=. + + #+begin_src emacs-lisp + ;; => ((0 1 2 nil nil) + ;; (3 4 5 [6 7]) + ;; (?a ?b ?c "")) + (loopy (list [&seq i j &optional k &rest r] '((0 1) [3 4 5 6 7] "abc")) + (collect (list i j k r))) + #+end_src + ** Generic Evaluation :PROPERTIES: @@ -2099,6 +2118,96 @@ source sequences. (collect i)) #+END_SRC +#+findex: stream +#+findex: streaming +- =(stream VAR EXPR &key by)= :: Iterate through the elements for the stream + =EXPR=. If =by= is non-nil (default: 1), then move to the next n-th element + during each iteration. This command is a special case of the =substream= + command (described below), setting =VAR= to the first element of each + substream. For more information, see the command =substream=. + + This command also has the alias =streaming=. + + #+begin_src emacs-lisp + ;; => (0 1 2) + (loopy (stream i (stream [0 1 2])) + (collect i)) + + ;; Same as the above: + ;; => (0 1 2) + (loopy (substream i (stream [0 1 2])) + (collect (stream-first i))) + #+end_src + +#+findex: substream +#+findex: substreaming +- =(substream VAR EXPR &key by length)= :: Iterate through the sub-streams of + stream =EXPR=, similar to the command =cons=. If =by= is non-nil (default: + 1), then move to the next n-th substream during each iteration. If =length= + is given, then the substream bound to =VAR= is only the specified length. + + This command operates on the =stream= type defined by the library =stream= + [[https://elpa.gnu.org/packages/stream.html][from GNU ELPA]], which is not to be confused with the Emacs Lisp "input streams" + and "output streams" used for reading and printing text ([[info:elisp#Read and + Print]]). The "streams" defined by the =stream= library are like lazy sequences + and are compatible with features from the built-in =seq= library, such as + ~seq-elt~ and ~seq-do~. + + For efficiency, when possible, =VAR= is initialized to the value of =EXPR=, + not ~nil~, and is updated at the end of each step in the loop. This is not + possible when destructuring. Such initialization can be overridden by using + the =with= special macro argument, which can result in slower code. + + Sub-streams can only be destructured using the =&seq= feature of the default + destructuring method ([[#basic-destructuring][Basic Destructuring]]), or by using the =seq= flag + ([[#flags][Using Flags]]). Streams are neither lists nor arrays. + + This command also has the alias =substreaming=. + + #+begin_src emacs-lisp + (require 'stream) + + ;; => (0 1 2) + (loopy (substream i (stream [0 1 2])) + (collect (stream-first i))) + + ;; => ((0 1 2) + ;; (1 2 nil) + ;; (2 nil nil)) + (loopy (substream [&seq i j k] (stream [0 1 2])) + (collect (list i j k))) + + ;; => ((0 1) + ;; (1 2) + ;; (2 3) + ;; (3 nil)) + (loopy (flag seq) + ;; Using the `seq.el' library to destructure, + ;; not destructuring as a list: + (substream (i j) (stream '(0 1 2 3))) + (collect (list i j))) + + ;; => ((0 1 2 3 4 5) + ;; (2 3 4 5) + ;; (4 5)) + (loopy (substream i (stream [0 1 2 3 4 5]) :by 2) + (set inner-result nil) + (do (seq-do (lambda (x) (push x inner-result)) + i)) + (collect (reverse inner-result))) + + ;; => ((0 1) + ;; (2 3) + ;; (4 5)) + (loopy (set inner-result nil) + ;; Using `:length' limits the length of the substream + ;; bound to `i'. + (substream i (stream [0 1 2 3 4 5]) :by 2 :length 2) + (do (seq-do (lambda (x) (push x inner-result)) + i)) + (collect (reverse inner-result))) + #+end_src + *** Sequence Index Iteration :PROPERTIES: :CUSTOM_ID: sequence-index-iteration diff --git a/loopy-commands.el b/loopy-commands.el index 3d3a36f10..34cb6aca9 100644 --- a/loopy-commands.el +++ b/loopy-commands.el @@ -83,6 +83,7 @@ (require 'pcase) (require 'seq) (require 'subr-x) +(require 'stream) (declare-function loopy--bound-p "loopy") (declare-function loopy--process-instructions "loopy") @@ -1087,6 +1088,8 @@ NAME is the name of the command." (num-steps (if count-given count var-or-count))) + ;; TODO: If we know at compile-time that num-steps is 1, + ;; can we avoid creating the loop? `((loopy--iteration-vars (,value-holder 0)) ,(when bound-and-given `(loopy--main-body (setq ,var-or-count ,value-holder))) @@ -1354,6 +1357,58 @@ KEYS is one or several of `:index', `:by', `:from', `:downfrom', (setq ,seq-index (,(if going-down #'- #'+) ,seq-index ,by))))))))))))) +;;;;;; Substream +(loopy--defiteration substream + "Parse the `substream' command as (substream VAR STREAM &keys by length). + +Iterate through the sub-streams of STREAM, similar to the command `cons'. + +If STREAM is not destructured, VAR is not `with' bound, and +LENGTH is not given, then VAR can be initialized as STREAM. + +`:by' is a numeric value telling which substream to move to (default: 1). +`:length' is a numeric value that, if given, limits the length of the stream +bound to VAR." + :keywords (:by :length) + :instructions + (progn + (when (and (seqp var) + (or (null loopy--destructuring-for-iteration-function) + (eq loopy--destructuring-for-iteration-function + #'loopy--destructure-for-iteration-default)) + (not (eq '&seq (seq-first var)))) + (signal 'loopy-substream-not-&seq (list cmd))) + (let ((optimized (not (or length (seqp var) (loopy--with-bound-p var))))) + (loopy--instr-let-const* ((step-holder (or by 1)) + (len length)) + loopy--iteration-vars + (loopy--instr-let-var* ((value-holder `(stream-delay ,val) + (when optimized + var))) + loopy--iteration-vars + `((loopy--pre-conditions (not (stream-empty-p ,value-holder))) + ,@(unless optimized + (loopy--destructure-for-iteration-command + var (if len + `(seq-take ,value-holder ,len) + value-holder))) + (loopy--latter-body + (setq ,value-holder (seq-drop ,value-holder ,step-holder))))))))) + +;;;;;; Stream +(loopy--defiteration stream + "Parse the `stream' command as (stream VAR STREAM &keys by). + +Iterate through the elements of STREAM, similar to the command `list'. + +`:by' is a numeric value telling which element to move to (default: 1)." + :keywords (:by) + :instructions + (let ((value-holder (gensym "stream-holder"))) + `(,@(loopy--parse-substream-command `(substream ,value-holder ,val :by ,by)) + ,@(loopy--destructure-for-iteration-command + var `(stream-first ,value-holder))))) + ;;;;; Accumulation ;;;;;; Compatibility (defvar loopy--known-accumulation-categories @@ -2820,9 +2875,11 @@ Returns a list. The elements are: in VAL. 2. A list of variables which exist outside of this expression and need to be `let'-bound." - (funcall (or loopy--destructuring-for-iteration-function - #'loopy--destructure-for-iteration-default) - var val)) + (pcase-let ((`(,expr ,vars) + (funcall (or loopy--destructuring-for-iteration-function + #'loopy--destructure-for-iteration-default) + var val))) + (list expr (seq-uniq vars #'eq)))) ;; TODO: Rename these so that the current "iteration" features ;; are "generic" and the new "iteration" features diff --git a/loopy-destructure.el b/loopy-destructure.el index 6d48ee728..085ac09e3 100644 --- a/loopy-destructure.el +++ b/loopy-destructure.el @@ -34,6 +34,7 @@ (require 'loopy-misc) (require 'loopy-instrs) (require 'pcase) +(require 'stream) (require 'seq) (require 'subr-x) @@ -45,195 +46,235 @@ (and (symbolp var) (eq (aref (symbol-name var) 0) ?_))) -(defconst loopy--destructure-symbols '( &whole &optional &rest &body +(defconst loopy--destructure-symbols '( &seq &whole &optional &rest &body &key &keys &allow-other-keys &aux &map) "Symbols affecting how following elements destructure.") ;; Having a single function for all categories allows us to have most of the ;; ordering rules in once place. +(defconst loopy--get-var-groups-cache (make-hash-table :test 'equal :size 300) + "Cache of variable groups in a pattern. +See also the function `loopy--get-var-groups'.") + (defun loopy--get-var-groups (var-seq) "Return the alist of variable groups in sequence VAR-SEQ. Type is one of `list' or `array'." - (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) - (map-var) (processing-maps) - (aux-var) (processing-auxs) - (proper-list-p (proper-list-p var-seq)) - (type (cl-etypecase var-seq - (list 'list) - (array 'array))) - (improper-list (and (eq type 'list) - (not proper-list-p))) - (remaining-seq (if improper-list - (cl-copy-list var-seq) - (copy-sequence var-seq)))) - - (when improper-list - (cl-shiftf dotted-rest-var - (cdr (last remaining-seq)) - nil)) - - (cl-flet ((missing-after (seq) (or (seq-empty-p seq) - (memq (seq-elt seq 0) - loopy--destructure-symbols))) - (stop-processing () (setq processing-whole nil - processing-opts nil - processing-rest nil - processing-keys nil - processing-maps nil))) - - ;; Use `seq' functions to support arrays now and maybe other things later. - (while (not (seq-empty-p remaining-seq)) - (seq-let [first &rest rest] - remaining-seq - (pcase first - ('&whole (cond - ;; Make sure there is a variable named. - ((missing-after rest) - (signal 'loopy-&whole-missing (list var-seq))) - ;; Make sure `&whole' is before all else. - ((or whole-var pos-var opt-var rest-var key-var - allow-other-keys aux-var map-var) - (signal 'loopy-&whole-bad-position (list var-seq))) - (t - (stop-processing) - (setq processing-whole t)))) - - ('&optional (cond - ((missing-after rest) - (signal 'loopy-&optional-missing - (list var-seq))) - ;; Make sure `&optional' does not occur after - ;; `&rest'. - ((or opt-var rest-var key-var map-var aux-var) - (signal 'loopy-&optional-bad-position - (list var-seq))) - (t - (stop-processing) - (setq processing-opts t)))) - - ((or '&rest '&body) (cond - (dotted-rest-var - (signal 'loopy-&rest-dotted - (list var-seq))) - ((missing-after rest) - (signal 'loopy-&rest-missing - (list var-seq))) - ((and (> (seq-length rest) 1) - (let ((after-var (seq-elt rest 1))) - (not (memq after-var loopy--destructure-symbols)))) - (signal 'loopy-&rest-multiple (list var-seq))) - ;; In CL Lib, `&rest' must come before `&key', - ;; but we decided to allow it to come after. - ((or aux-var rest-var) - (signal 'loopy-&rest-bad-position - (list var-seq))) - (t - (stop-processing) - (setq processing-rest t)))) - - ((or '&key '&keys) (cond - ((not (eq type 'list)) - (signal 'loopy-&key-array - (list var-seq))) - ((missing-after rest) - (signal 'loopy-&key-missing - (list var-seq))) - ((or aux-var key-var) - (signal 'loopy-&key-bad-position - (list var-seq))) - (t - (stop-processing) - (setq processing-keys t)))) - - ('&allow-other-keys (cond - ((not (eq type 'list)) - (signal 'loopy-&key-array - (list var-seq))) - ((not processing-keys) - (signal 'loopy-&allow-other-keys-without-&key - (list var-seq))) - (t - (stop-processing) - (setq allow-other-keys t)))) - - ('&map (cond - ((missing-after rest) - (signal 'loopy-&map-missing (list var-seq))) - ((or aux-var map-var) - (signal 'loopy-&map-bad-position - (list var-seq))) - (t - (stop-processing) - (setq processing-maps t)))) - - ('&aux - (if (or (missing-after rest) - aux-var) - (signal 'loopy-&aux-bad-position (list var-seq)) - (stop-processing) - (setq processing-auxs t))) - - ('&environment - (signal 'loopy-bad-desctructuring (list var-seq))) - - ((guard processing-whole) - (cond - ((loopy--var-ignored-p first) - (signal 'loopy-&whole-missing (list var-seq))) - (t - (setq whole-var first - processing-whole nil)))) - - ((guard processing-rest) - ;; `&rest' var can be ignored for clarity, - ;; but it is probably an error to ignore it - ;; when there are no positional or optional variables. - (if (and (loopy--var-ignored-p first) - (null pos-var) - (null opt-var)) - (signal 'loopy-&rest-missing - (list var-seq)) - (setq rest-var first - processing-rest nil))) - - ((guard processing-opts) - (if (and (consp first) - (cdr first) - (loopy--var-ignored-p (car first))) - (signal 'loopy-&optional-ignored-default-or-supplied - (list var-seq)) - (push first opt-var))) - - ((guard processing-keys) - (push first key-var)) - - ((guard processing-maps) - (push first map-var)) - - ((guard processing-auxs) - (push first aux-var)) - - (_ - (if (or opt-var rest-var key-var map-var aux-var - allow-other-keys) - (signal 'loopy-bad-desctructuring (list var-seq)) - (push first pos-var))))) - - (setq remaining-seq (seq-rest remaining-seq)))) - - `((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) - (map . ,(nreverse map-var)) - (aux . ,(nreverse aux-var))))) + (or (gethash var-seq loopy--get-var-groups-cache nil) + (let* ((is-seq) + (whole-var) (processing-whole) + (pos-var) + (opt-var) (processing-opts) + (rest-var) (processing-rest) (dotted-rest-var) + (key-var) (processing-keys) (allow-other-keys) + (map-var) (processing-maps) + (aux-var) (processing-auxs) + (proper-list-p (proper-list-p var-seq)) + (type (cl-etypecase var-seq + (list 'list) + (array 'array))) + (improper-list (and (eq type 'list) + (not proper-list-p))) + (remaining-seq (if improper-list + (cl-copy-list var-seq) + (copy-sequence var-seq)))) + + (when improper-list + (cl-shiftf dotted-rest-var + (cdr (last remaining-seq)) + nil)) + + (cl-flet ((missing-after (seq) (or (seq-empty-p seq) + (memq (seq-elt seq 0) + loopy--destructure-symbols))) + (stop-processing () (setq processing-whole nil + processing-opts nil + processing-rest nil + processing-keys nil + processing-maps nil))) + + ;; Use `seq' functions to support arrays now and maybe other things later. + (while (not (seq-empty-p remaining-seq)) + (seq-let [first &rest rest] + remaining-seq + (pcase first + ;; Since `&seq' must be first, we could check for it outside of + ;; processing, but we keep it with the other processing for + ;; consistency. + ('&seq (cond + ((or is-seq whole-var pos-var opt-var rest-var key-var + allow-other-keys aux-var map-var) + (signal 'loopy-&seq-bad-position (list var-seq))) + ((seq-empty-p rest) + (signal 'loopy-bad-desctructuring + (list var-seq))) + (t + (stop-processing) + (setq is-seq t)))) + ('&whole (cond + ;; Make sure there is a variable named. + ((missing-after rest) + (signal 'loopy-&whole-missing (list var-seq))) + ;; Make sure `&whole' is before all else. + ((or whole-var pos-var opt-var rest-var key-var + allow-other-keys aux-var map-var) + (signal 'loopy-&whole-bad-position (list var-seq))) + (t + (stop-processing) + (setq processing-whole t)))) + + ('&optional (cond + ((missing-after rest) + (signal 'loopy-&optional-missing + (list var-seq))) + ;; Make sure `&optional' does not occur after + ;; `&rest'. + ((or opt-var rest-var key-var map-var aux-var) + (signal 'loopy-&optional-bad-position + (list var-seq))) + (t + (stop-processing) + (setq processing-opts t)))) + + ((or '&rest '&body) (cond + (dotted-rest-var + (signal 'loopy-&rest-dotted + (list var-seq))) + ((missing-after rest) + (signal 'loopy-&rest-missing + (list var-seq))) + ((and (> (seq-length rest) 1) + (let ((after-var (seq-elt rest 1))) + (not (memq after-var loopy--destructure-symbols)))) + (signal 'loopy-&rest-multiple (list var-seq))) + ;; In CL Lib, `&rest' must come before `&key', + ;; but we decided to allow it to come after. + ((or aux-var rest-var) + (signal 'loopy-&rest-bad-position + (list var-seq))) + (t + (stop-processing) + (setq processing-rest t)))) + + ((or '&key '&keys) (cond + ((not (eq type 'list)) + (signal 'loopy-&key-array + (list var-seq))) + ((missing-after rest) + (signal 'loopy-&key-missing + (list var-seq))) + ((or aux-var key-var) + (signal 'loopy-&key-bad-position + (list var-seq))) + (t + (stop-processing) + (setq processing-keys t)))) + + ('&allow-other-keys (cond + ((not (eq type 'list)) + (signal 'loopy-&key-array + (list var-seq))) + ((not processing-keys) + (signal 'loopy-&allow-other-keys-without-&key + (list var-seq))) + (t + (stop-processing) + (setq allow-other-keys t)))) + + ('&map (cond + ((missing-after rest) + (signal 'loopy-&map-missing (list var-seq))) + ((or aux-var map-var) + (signal 'loopy-&map-bad-position + (list var-seq))) + (t + (stop-processing) + (setq processing-maps t)))) + + ('&aux + (if (or (missing-after rest) + aux-var) + (signal 'loopy-&aux-bad-position (list var-seq)) + (stop-processing) + (setq processing-auxs t))) + + ('&environment + (signal 'loopy-bad-desctructuring (list var-seq))) + + ((guard processing-whole) + (cond + ((loopy--var-ignored-p first) + (signal 'loopy-&whole-missing (list var-seq))) + (t + (setq whole-var first + processing-whole nil)))) + + ((guard processing-rest) + ;; `&rest' var can be ignored for clarity, + ;; but it is probably an error to ignore it + ;; when there are no positional or optional variables. + (if (and (loopy--var-ignored-p first) + (null pos-var) + (null opt-var)) + (signal 'loopy-&rest-missing + (list var-seq)) + (setq rest-var first + processing-rest nil))) + + ((guard processing-opts) + (if (and (consp first) + (cdr first) + (loopy--var-ignored-p (car first))) + (signal 'loopy-&optional-ignored-default-or-supplied + (list var-seq)) + (push first opt-var))) + + ((guard processing-keys) + (push first key-var)) + + ((guard processing-maps) + (push first map-var)) + + ((guard processing-auxs) + (push first aux-var)) + + (_ + (if (or opt-var rest-var key-var map-var aux-var + allow-other-keys) + (signal 'loopy-bad-desctructuring (list var-seq)) + (push first pos-var))))) + + (setq remaining-seq (seq-rest remaining-seq)))) + + (let ((val `((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) + (map . ,(nreverse map-var)) + (aux . ,(nreverse aux-var)) + (seq . ,is-seq)))) + (puthash var-seq val loopy--get-var-groups-cache) + val)))) + +;; TODO: Turn these into records? +(defun loopy--get-&optional-spec (form) + "Get the spec of the `&optional' variable FORM as (VAR DEFAULT SUPPLIED LEN)." + (let ((var) + (default) + (supplied) + (len)) + (loopy--pcase-let-workaround (var2 def2 sup2) + (pcase form + ;; Uses `nil' if not long enough. + ((and (seq var2 def2 sup2) form2) (setq var var2 + default def2 + supplied sup2 + len (seq-length form2))) + (form2 (setq var form2 + len 0)))) + (list var default supplied len))) (defun loopy--get-&key-spec (var-form) "Get the spec of `&key' VAR-FORM as (KEY VAR DEFAULT SUPPLIED)." @@ -297,6 +338,50 @@ Type is one of `list' or `array'." (signal 'loopy-&aux-malformed-var (list var-form))) (list var val)))) +(defun loopy--get-var-list (var-seq) + "Get the variables in VAR-SEQ as a flat, unordered list." + (let ((groups (loopy--get-var-groups var-seq)) + (result nil)) + (cl-labels ((fn (val) (if (seqp val) + (dolist (val2 (loopy--get-var-list val)) + (cl-pushnew val2 result :test #'eq)) + (cl-pushnew val result))) + (opt-fn (val) (loopy--pcase-let-workaround (var supplied) + (seq-let [var _ supplied _] + (loopy--get-&optional-spec val) + (fn var) + (when supplied + (fn supplied))))) + (key-fn (val) (loopy--pcase-let-workaround (var supplied) + (seq-let [_ var _ supplied] + (loopy--get-&key-spec val) + (fn var) + (when supplied + (fn supplied))))) + (map-fn (val) (loopy--pcase-let-workaround (var supplied) + (seq-let [_ var _ supplied] + (loopy--get-&map-spec val) + (fn var) + (when supplied + (fn supplied))))) + (aux-fn (val) (loopy--pcase-let-workaround (var) + (seq-let [var _] + (loopy--get-&map-spec val) + (fn var))))) + (map-do (lambda (k v) + (when v + (pcase k + ((or 'whole 'rest) (fn v)) + ('pos (mapc #'fn v)) + ('opt (mapc #'opt-fn v)) + ('key (mapc #'key-fn v)) + ('map (mapc #'map-fn v)) + ('aux (mapc #'aux-fn v)) + ((or 'seq 'allow-other-keys) nil) + (_ (error "Unknown key"))))) + groups)) + result)) + ;;;; Pcase pattern (defun loopy--get-var-pattern (var) @@ -310,6 +395,17 @@ return `(loopy VAR)'. In all other cases, VAR is returned." ((seqp var) `(loopy ,var)) (t var))) +;; TODO: Use this in `list' pattern. +(defun loopy--pcase-let-nil-list (pat) + "Return a list of patterns binding variables in PAT to `nil'." + ;; Need to quote `nil' for it to be a `pcase' pattern. + (pcase pat + (`(loopy ,(and (pred seqp) seq)) + (cl-loop for v in (loopy--get-var-list seq) + collect `(let ,v 'nil))) + (_ + `((let ,pat 'nil))))) + (defun loopy--pcase-pat-positional-list-pattern (pos-vars opt-vars rest-var map-or-key-vars) "Build a pattern for the positional, `&optional', and `&rest' variables. @@ -326,25 +422,14 @@ MAP-OR-KEY-VARS is whether there are map or key variables." (cdr pos-vars) opt-vars rest-var map-or-key-vars)))) (opt-vars (loopy--pcase-let-workaround (var default supplied) - (pcase-let* (((or (seq var default supplied) - (seq var default) - (seq var) - var) - (car opt-vars)) + (pcase-let* ((`(,var ,default ,supplied ,length) + (loopy--get-&optional-spec (car opt-vars))) (var2 (loopy--get-var-pattern var))) `(and (pred listp) (app car-safe (or (and (pred null) - ,@(when supplied `((let ,supplied nil))) - ;; To destructure `nil' for a sequence, we need to - ;; mark the `&optional' variables as optional. - ,(if default - `(let ,var2 ,default) - (if (seqp var) - `(let (loopy (&optional - ,@(seq-into (cl-second var2) - 'list))) - nil) - `(let ,var2 nil)))) + ,@(when supplied + `((let ,supplied nil))) + (let ,var2 ,default)) ,(if supplied `(and (let ,supplied t) ,var2) @@ -378,13 +463,7 @@ MAP-OR-KEY-VARS is whether there are map or key variables." collect `(app (pcase--flip aref ,idx) ,(loopy--get-var-pattern var))) ,@(when opt-vars - (let ((opt-var-specs (seq-into (mapcar (loopy--pcase-let-workaround (var default supplied) - (pcase-lambda ((or (seq var default supplied) - (seq var default) - (seq var) - (and (pred symbolp) - var))) - (list var default supplied))) + (let ((opt-var-specs (seq-into (mapcar #'loopy--get-&optional-spec opt-vars) 'vector))) `((or ,@(cl-loop with use->= = (or rest-var map-or-key-vars) @@ -405,9 +484,10 @@ MAP-OR-KEY-VARS is whether there are map or key variables." ,@(cl-loop for spec-idx2 from 0 to spec-idx-high for arr-idx from pat-idx-low - append (pcase-let* ((`(,var2 ,_ ,supplied2) (aref opt-var-specs spec-idx2)) + append (pcase-let* ((`(,var2 ,_ ,supplied2 ,len2) + (aref opt-var-specs spec-idx2)) (var3 (loopy--get-var-pattern var2))) - (if supplied2 + (if (= len2 3) `((app (pcase--flip aref ,arr-idx) ,var3) (let ,supplied2 t)) @@ -418,29 +498,31 @@ MAP-OR-KEY-VARS is whether there are map or key variables." ,@(cl-loop for spec-idx2 from (1+ spec-idx-high) to spec-idx-max for arr-idx from pat-idx-low - append (pcase-let* ((`(,var2 ,default2 ,supplied2) + append (pcase-let* ((`(,var2 ,default2 ,supplied2 ,len2) (aref opt-var-specs spec-idx2)) (var3 (loopy--get-var-pattern var2))) - (cond - (supplied2 - `((let ,var3 ,default2) - (let ,supplied2 nil))) - (default2 - `((let ,var3 ,default2))) - (t - `((let ,var3 nil)))))))) + (pcase-exhaustive len2 + (3 `((let ,var3 ,default2) + (let ,supplied2 nil))) + (2 `((let ,var3 ,default2))) + (_ + ;; (loopy--pcase-let-nil-list var3) + `((let ,var3 ,default2)) + )))))) ;; A pattern for when nothing matches. (and ,@(cl-loop for spec across opt-var-specs - append (pcase-let* ((`(,var2 ,default2 ,supplied2) spec) + append (pcase-let* ((`(,var2 ,default2 ,supplied2 ,len2) spec) (var3 (loopy--get-var-pattern var2))) - (cond - (supplied2 - `((let ,var3 ,default2) - (let ,supplied2 nil))) - (default2 - `((let ,var3 ,default2))) - (t - `((let ,var3 nil))))))))))) + (pcase-exhaustive len2 + (3 + `((let ,var3 ,default2) + (let ,supplied2 nil))) + (2 + `((let ,var3 ,default2))) + (_ + `((let ,var3 ,default2)) + ;; (loopy--pcase-let-nil-list var3) + ))))))))) ,@(when rest-var (let ((len-sum (+ pos-len opt-len)) @@ -453,6 +535,120 @@ MAP-OR-KEY-VARS is whether there are map or key variables." (app (lambda (,seqsym) (substring ,seqsym 0 0)) ,rest-pat)))))))) +(defun loopy--seq-length= (seq n) + (if (sequencep seq) + (compat-call length= seq n) + (= (seq-length seq) n))) + +(defun loopy--seq-length> (seq n) + (cond + ((sequencep seq) + (compat-call length> seq n)) + ;; Take advantage of lazy evaluation of streams. + ((streamp seq) + (not (stream-empty-p (seq-drop seq n)))) + ((seqp seq) + (> (seq-length seq) n)) + (t + (error "Not a known sequence type")))) + +(defun loopy--pcase-pat-positional-&seq-pattern (pos-vars opt-vars rest-var map-or-key-vars) + "Build a pattern for the positional, `&optional', and `&rest' variables. + +Unlike the build-in `seq' pattern, we don't match the sequence +if the destructuring pattern is longer than the +destructured value. + +POS-VARS is the list of the positional variables. OPT-VARS is the list of +the optional variables. REST-VAR is the `&rest' variable. +MAP-OR-KEY-VARS is whether there are map or key variables." + (let ((pos-len (length pos-vars)) + (opt-len (length opt-vars))) + (cl-labels ((make-pos-pats () + (cl-loop for v in pos-vars + for i from 0 + collect `(app (pcase--flip seq-elt ,i) + ,(loopy--get-var-pattern v))))) + `(and + ;; If there are optional values, then we can avoid the length check here + ;; by running the length check for the optional values, which we need to + ;; do anyway. + ,@(when (null opt-vars) + `((pred (pcase--flip loopy--seq-length> ,(1- pos-len))) + ,@(make-pos-pats))) + ;; Optional variables may or may not be expensive for generic + ;; sequences. This is the same logic as for arrays, just using the + ;; `seq-' functions. + ,@(when opt-vars + (let ((opt-var-specs (seq-into (mapcar #'loopy--get-&optional-spec + opt-vars) + 'vector))) + ;; TODO: When do we need this to be `=' instead of `> (1- ...)'? + `((or ,@(cl-loop with use->= = (or rest-var map-or-key-vars) + and pat-idx-low = pos-len + and spec-idx-max = (1- opt-len) + for checked-len from (+ pos-len opt-len) downto pos-len + for spec-idx-high downfrom (1- opt-len) to 0 + collect + ;; If the length matches, then all of the + ;; remaining variables were supplied, then + ;; the one variable was not supplied and we + ;; need to check the remaining ones. + `(and ,(if use->= + `(pred (pcase--flip loopy--seq-length> ,(1- checked-len))) + `(pred (pcase--flip loopy--seq-length= ,checked-len))) + ,@(when pos-vars + (make-pos-pats)) + ;; Variables that should be bound with the value in + ;; the array. + ,@(cl-loop + for spec-idx2 from 0 to spec-idx-high + for arr-idx from pat-idx-low + append (pcase-let* ((`(,var2 ,_ ,supplied2) (aref opt-var-specs spec-idx2)) + (var3 (loopy--get-var-pattern var2))) + (if supplied2 + `((app (pcase--flip seq-elt ,arr-idx) + ,var3) + (let ,supplied2 t)) + `((app (pcase--flip seq-elt ,arr-idx) + ,var3))))) + ;; Variables that should be bound to nil or their + ;; default. + ,@(cl-loop + for spec-idx2 from (1+ spec-idx-high) to spec-idx-max + for arr-idx from pat-idx-low + append (pcase-let* ((`(,var2 ,default2 ,supplied2 ,len2) + (aref opt-var-specs spec-idx2)) + (var3 (loopy--get-var-pattern var2))) + (pcase-exhaustive len2 + (3 `((let ,var3 ,default2) + (let ,supplied2 nil))) + (2 `((let ,var3 ,default2))) + (_ + `((let ,var3 ,default2)) + ;; (loopy--pcase-let-nil-list var3) + )))))) + ;; A pattern for when nothing matches. + (and ,@(cl-loop for spec across opt-var-specs + append (pcase-let* ((`(,var2 ,default2 ,supplied2 ,len2) spec) + (var3 (loopy--get-var-pattern var2))) + `(,@(when supplied2 + `((let ,supplied2 nil))) + (let ,var3 ,default2) + ;; ,@(cond + ;; ((or (eq default2 '_) + ;; (= len2 1)) + ;; (loopy--pcase-let-nil-list var3)) + ;; ((= len2 2) + ;; `((let ,var3 ,default2)))) + ))) + ,@(when pos-vars + `((pred (pcase--flip loopy--seq-length> ,(1- pos-len))) + ,@(make-pos-pats)))))))) + ,@(when rest-var + `((app (pcase--flip seq-drop ,(+ pos-len opt-len)) + ,(loopy--get-var-pattern rest-var)))))))) + (defun loopy--pcase-pat-&key-pattern (key-vars allow-other-keys) "Build a `pcase' pattern for the `&key' variables. @@ -519,11 +715,11 @@ holding the property list." (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)))) + (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) @@ -540,7 +736,7 @@ holding the property list." ;; of `(not null)' to support ;; older version of Emacs. '(pred identity) - pats)) + pats)) collect `(,'\, ,pat)))))))) (defun loopy--pcase-pat-&map-pattern (map-vars) @@ -601,6 +797,7 @@ See the Info node `(loopy)Basic Destructuring'." ((symbolp sequence) sequence) (t (let* ((groups (loopy--get-var-groups sequence)) + (is-seq (alist-get 'seq groups)) (whole-var (alist-get 'whole groups)) (pos-vars (alist-get 'pos groups)) (opt-vars (alist-get 'opt groups)) @@ -614,35 +811,46 @@ See the Info node `(loopy)Basic Destructuring'." whole-var) ,@(when (or pos-vars opt-vars rest-var key-vars map-vars allow-other-keys) - (cl-etypecase sequence - (list - `((pred listp) - ,(when (or pos-vars opt-vars rest-var) - (loopy--pcase-pat-positional-list-pattern - pos-vars opt-vars - rest-var (or key-vars map-vars))) - ,(when key-vars - (cond - ((and rest-var - (not (loopy--var-ignored-p rest-var))) - `(app (lambda (_) ,rest-var) - ,(loopy--pcase-pat-&key-pattern - key-vars allow-other-keys))) - ((or pos-vars opt-vars) - `(app (nthcdr ,(+ (length pos-vars) - (length opt-vars))) - ,(loopy--pcase-pat-&key-pattern - key-vars allow-other-keys))) - (t (loopy--pcase-pat-&key-pattern - key-vars allow-other-keys)))))) - (array - `((pred arrayp) - ,(when (or pos-vars opt-vars rest-var) - (loopy--pcase-pat-positional-array-pattern - pos-vars opt-vars - rest-var key-vars)) - ,(when key-vars - (signal 'loopy-&key-array (list sequence))))))) + (cond + (is-seq + `((pred seqp) + ,(when (or pos-vars opt-vars rest-var) + (loopy--pcase-pat-positional-&seq-pattern + pos-vars opt-vars + rest-var (or key-vars map-vars))) + ,(when key-vars + (signal 'loopy-&key-seq (list sequence))))) + ((listp sequence) + `((pred listp) + ,(when (or pos-vars opt-vars rest-var) + (loopy--pcase-pat-positional-list-pattern + pos-vars opt-vars + rest-var (or key-vars map-vars))) + ,(when key-vars + (cond + ((and rest-var + (not (loopy--var-ignored-p rest-var))) + `(app (lambda (_) ,rest-var) + ,(loopy--pcase-pat-&key-pattern + key-vars allow-other-keys))) + ((or pos-vars opt-vars) + `(app (nthcdr ,(+ (length pos-vars) + (length opt-vars))) + ,(loopy--pcase-pat-&key-pattern + key-vars allow-other-keys))) + (t (loopy--pcase-pat-&key-pattern + key-vars allow-other-keys)))))) + ((arrayp sequence) + `((pred arrayp) + ,(when (or pos-vars opt-vars rest-var) + (loopy--pcase-pat-positional-array-pattern + pos-vars opt-vars + rest-var key-vars)) + ,(when key-vars + (signal 'loopy-&key-array (list sequence))))) + (t + (signal 'loopy-bad-desctructuring + (list sequence))))) ,(when map-vars (cond ((and rest-var @@ -650,8 +858,8 @@ See the Info node `(loopy)Basic Destructuring'." `(app (lambda (_) ,rest-var) ,(loopy--pcase-pat-&map-pattern map-vars))) ((or pos-vars opt-vars) - `(app (pcase--flip seq-subseq ,(+ (length pos-vars) - (length opt-vars))) + `(app (pcase--flip seq-drop ,(+ (length pos-vars) + (length opt-vars))) ,(loopy--pcase-pat-&map-pattern map-vars))) (t (loopy--pcase-pat-&map-pattern map-vars)))) @@ -733,7 +941,7 @@ the pattern doesn't match." (pcase--macroexpand '_)) #'signaler))))))))) (list destructuring-expression - var-list)))) + (seq-uniq var-list #'eq))))) (defun loopy--pcase-destructure-for-with-vars (bindings) "Return a way to destructure BINDINGS by `pcase-let*'. @@ -837,12 +1045,182 @@ an error should be signaled if the pattern doesn't match." VALUE-EXPRESSION should itself be a `setf'-able place. Returns a list of bindings suitable for `cl-symbol-macrolet'." - (cl-typecase var - (symbol (unless (loopy--var-ignored-p var) - `((,var ,value-expression)))) - (list (loopy--destructure-generalized-list var value-expression)) - (array (loopy--destructure-generalized-array var value-expression)) - (t (signal 'loopy-destructure-type (list var))))) + (pcase var + ((pred symbolp) (unless (loopy--var-ignored-p var) + `((,var ,value-expression)))) + ((pred (lambda (x) (map-elt (loopy--get-var-groups x) 'seq))) + (loopy--destructure-generalized-&seq var value-expression)) + ((pred listp) (loopy--destructure-generalized-list var value-expression)) + ((pred arrayp) (loopy--destructure-generalized-array var value-expression)) + (_ (signal 'loopy-destructure-type (list var))))) + +(define-inline loopy--destructure-seq-drop (sequence n) + "A wrapper for `seq-drop' so that `setf' places can be recursive." + (declare (gv-expander + (lambda (do) + (gv-letplace (getter setter) `(gv-delay-error ,sequence) + (macroexp-let2* nil ((n n)) + (funcall do + `(seq-drop ,getter ,n) + (lambda (v) + (macroexp-let2 nil v v + `(progn + ,(funcall setter + `(loopy--destructure-seq-replace + ,getter ,v ,n)) + ,v))))))))) + (inline-letevals (sequence n) + (inline-quote (seq-drop ,sequence ,n)))) + +(cl-defgeneric loopy--destructure-seq-replace (sequence replacements start &optional end) + "Replace elements of SEQUENCE from START to END with elements of REPLACEMENTS. +END is exclusive." + (let* ((len (seq-length sequence)) + (signal-fn (lambda () + (signal 'args-out-of-range + (if end + (list sequence start end) + (list sequence start))))) + (signal-or-val-fn (lambda (val) + (cond + ((> val len) + (funcall signal-fn)) + ((< val 0) + (let ((val2 (+ val len))) + (if (< val2 0) + (funcall signal-fn) + val2))) + (t + val)))) + (idx-start (funcall signal-or-val-fn start)) + (idx-end (if (null end) + len + (funcall signal-or-val-fn end)))) + (if (> idx-start idx-end) + (funcall signal-fn) + (let ((replacement-idx 0) + (replacement-len (seq-length replacements))) + (seq-into (seq-map-indexed (lambda (elem idx) + (if (and (<= idx-start idx) + (< idx idx-end) + (< replacement-idx replacement-len)) + (prog1 + (seq-elt replacements replacement-idx) + (setq replacement-idx (1+ replacement-idx))) + elem)) + sequence) + (if (listp sequence) + 'list + (type-of sequence))))))) + +(cl-defmethod loopy--destructure-seq-replace (sequence (replacements list) start &optional end) + "Replace elements of SEQUENCE from START to END with elements of REPLACEMENTS. +END is exclusive." + (let* ((len (seq-length sequence)) + (signal-fn (lambda () + (signal 'args-out-of-range + (if end + (list sequence start end) + (list sequence start))))) + (signal-or-val-fn (lambda (val) + (cond + ((> val len) + (funcall signal-fn)) + ((< val 0) + (let ((val2 (+ val len))) + (if (< val2 0) + (funcall signal-fn) + val2))) + (t + val)))) + (idx-start (funcall signal-or-val-fn start)) + (idx-end (if (null end) + len + (funcall signal-or-val-fn end)))) + (if (> idx-start idx-end) + (funcall signal-fn) + (seq-into (seq-map-indexed (lambda (elem idx) + (if (and (<= idx-start idx) + (< idx idx-end) + replacements) + (pop replacements) + elem)) + sequence) + (if (listp sequence) + 'list + (type-of sequence)))))) + +(defun loopy--destructure-generalized-&seq (var-form value-expression) + "Destructure VALUE-EXPRESSION according to VAR-FORM as `setf'-able places. + +VALUE-EXPRESSION should itself be a `setf'-able place. + +Returns a list of bindings suitable for `cl-symbol-macrolet'. + +- `&rest' references a subsequence place. +- `&whole' references the entire place. +- `&optional' is not supported. +- `&map' references the values in the map. +- `&key' references the values in the property list." + (map-let (('whole whole-var) + ('pos pos-vars) + ('opt opt-vars) + ('rest rest-var) + ('key key-vars) + ('allow-other-keys allow-other-keys) + ('map map-vars) + ('aux aux-vars)) + (loopy--get-var-groups var-form) + `(,@(when whole-var + `((,whole-var ,value-expression))) + ,@(when pos-vars + (cl-loop for v in pos-vars + for n from 0 + for expr = `(seq-elt ,value-expression ,n) + if (seqp v) + append (loopy--destructure-generalized-sequence + v expr) + else + append `((,v ,expr)))) + ,@(when opt-vars + (signal 'loopy-&optional-generalized-variable + (list var-form value-expression))) + ,@(when rest-var + (let ((rest-val `(loopy--destructure-seq-drop + ,value-expression + ,(+ (length pos-vars) + (length opt-vars))))) + (if (seqp rest-var) + (loopy--destructure-generalized-sequence rest-var rest-val) + `((,rest-var ,rest-val))))) + ,@(when (or key-vars allow-other-keys) + (signal 'loopy-&key-seq + (list var-form value-expression))) + ,@(when map-vars + (cl-loop + for elem in map-vars + for (key var2 default supplied) = (loopy--get-&map-spec elem) + for expr = `(map-elt + (loopy--destructure-seq-drop ,value-expression + ,(+ (length pos-vars) + (length opt-vars))) + ,key ,default) + if default + do (signal 'loopy-generalized-default + (list var-form value-expression)) + else if supplied + do (signal 'loopy-generalized-supplied + (list var-form value-expression)) + else if (seqp var2) + append (loopy--destructure-generalized-sequence + var2 expr) + else + append `((,var2 ,expr)) + end)) + ,@(when aux-vars + (cl-loop for elem in aux-vars + for (var val) = (loopy--get-&aux-spec elem) + collect `(,var ,val)))))) (defun loopy--destructure-generalized-array (var-form value-expression) "Destructure VALUE-EXPRESSION according to VAR-FORM as `setf'-able places. diff --git a/loopy-iter.el b/loopy-iter.el index 4c120243f..8c2023c90 100644 --- a/loopy-iter.el +++ b/loopy-iter.el @@ -157,8 +157,10 @@ Without these keywords, one must use one of the names given in stringing stringing-index stringing-ref - thereis + streaming + substreaming summing + thereis unioning vconcating) "Commands recognized in `loopy-iter' without a preceding keyword. diff --git a/loopy-misc.el b/loopy-misc.el index ab7ab3c73..75eb521d5 100644 --- a/loopy-misc.el +++ b/loopy-misc.el @@ -129,6 +129,10 @@ "Loopy: `&whole' in bad position" 'loopy-bad-desctructuring) +(define-error 'loopy-&seq-bad-position + "Loopy: `&seq' in bad position" + 'loopy-bad-desctructuring) + (define-error 'loopy-&rest-missing "Loopy: `&rest' variable is missing" 'loopy-bad-desctructuring) @@ -193,6 +197,10 @@ "Loopy: Use of `&key' in array" 'loopy-bad-desctructuring) +(define-error 'loopy-&key-seq + "Loopy: Use of `&key' for generic `&seq' sequence" + 'loopy-bad-desctructuring) + (define-error 'loopy-&key-key-from-sequence "Loopy: Can't create `&key' key from a sequence" 'loopy-bad-desctructuring) @@ -229,6 +237,10 @@ "Loopy: No variables bound" 'loopy-bad-desctructuring) +(define-error 'loopy-substream-not-&seq + "Loopy: `substream' values can only be destructured via `&seq'" + '(loopy-bad-desctructuring loopy-bad-command-arguments)) + ;;;;; Errors on Quoted Forms (define-error 'loopy-bad-function-form "Loopy: Unrecognized function form" diff --git a/loopy-pkg.el b/loopy-pkg.el index c354aabf8..607dfb4f1 100644 --- a/loopy-pkg.el +++ b/loopy-pkg.el @@ -3,6 +3,7 @@ '((emacs "27.1") (map "3.3.1") (seq "2.22") - (compat "29.1.3")) + (compat "29.1.3") + (stream "2.3.0")) :homepage "https://github.com/okamsn/loopy" :keywords '("extensions")) diff --git a/loopy-vars.el b/loopy-vars.el index 5a9502474..3f298c37d 100644 --- a/loopy-vars.el +++ b/loopy-vars.el @@ -140,6 +140,8 @@ Definition must exist. Neither argument need be quoted." elements-ref)) (skip . (skipping continue continuing)) (skip-from . (skipping-from continue-from continuing-from)) + (stream . (streaming)) + (substream . (substreaming)) (sum . (summing)) (union . (unioning)) (vconcat . (vconcating)) @@ -208,6 +210,8 @@ true names and lists of aliases. (set-prev . loopy--parse-set-prev-command) (skip . loopy--parse-skip-command) (skip-from . loopy--parse-skip-from-command) + (stream . loopy--parse-stream-command) + (substream . loopy--parse-substream-command) (sum . loopy--parse-sum-command) (thereis . loopy--parse-thereis-command) (union . loopy--parse-union-command) diff --git a/loopy.el b/loopy.el index ef4ba7de2..767323813 100644 --- a/loopy.el +++ b/loopy.el @@ -6,7 +6,7 @@ ;; Created: November 2020 ;; URL: https://github.com/okamsn/loopy ;; Version: 0.12.3 -;; Package-Requires: ((emacs "27.1") (map "3.3.1") (seq "2.22") (compat "29.1.3")) +;; Package-Requires: ((emacs "27.1") (map "3.3.1") (seq "2.22") (compat "29.1.3") (stream "2.3.0")) ;; Keywords: extensions ;; LocalWords: Loopy's emacs Edebug diff --git a/tests/misc-tests.el b/tests/misc-tests.el index c5e0ae0b7..4dfd11937 100644 --- a/tests/misc-tests.el +++ b/tests/misc-tests.el @@ -1,4 +1,4 @@ -;; Tests of secondary features and helper functions. +;; Tests of secondary features and helper functions. -*- lexical-binding: t; -*- (push (expand-file-name ".") load-path) @@ -6,9 +6,14 @@ (require 'cl-lib) (require 'package) -(unless (featurep 'compat) - (dolist (dir (cl-remove-if-not #'file-directory-p (directory-files (expand-file-name package-user-dir) t "compat"))) - (push dir load-path))) +(dolist (feature '(compat stream)) + (unless (featurep feature) + (dolist (dir (seq-filter #'file-directory-p + (directory-files + (expand-file-name package-user-dir) + t + (symbol-name feature)))) + (push dir load-path)))) (require 'map) (require 'ert) @@ -83,47 +88,6 @@ INPUT is the destructuring usage. OUTPUT-PATTERN is what to match." (should-error (loopy--destructure-for-iteration-default [_ _] 'val) :type 'loopy-destructure-vars-missing)) -(ert-deftest loopy-let*-prev-val () - "Make sure we don't shadow values. -Later bindings can have access to the values of earlier bindings. -Later variables in the same destructuring should not use the -new values of the earlier variables." - (should (equal '(2 3 13 107) - (eval (quote (let ((a 1) - (b 2) - (c 7) - (d 33)) - (loopy-let* (((a b) (list (1+ a) (1+ b))) - (f (lambda (x) (+ 100 x))) - ([c d] (vector (+ 10 b) - (funcall f c)))) - (list a b c d)))) - t)))) - -(ert-deftest destructure-arrays () - (should (equal '(1 2 3) - (eval (quote (loopy-let* (([a b c] [1 2 3])) - (list a b c)))))) - - (should (equal '([1 2 3] 1 2 3) - (eval (quote (loopy-let* (([&whole cat a b c] [1 2 3])) - (list cat a b c)))))) - - (should (equal '(1 [2 3]) - (eval (quote (loopy-let* (([a &rest b] [1 2 3])) - (list a b)))))) - - (should (equal '([1 2 3] 1 [2 3]) - (eval (quote (loopy-let* (([&whole cat a &rest b] [1 2 3])) - (list cat a b)))))) - - (should (equal '(1 2 3) - (eval (quote (loopy-let* (([a &rest [b c]] [1 2 3])) - (list a b c)))))) - - (should (equal '([1 2 3] 1 2 3) - (eval (quote (loopy-let* (([&whole cat a &rest [b c]] [1 2 3])) - (list cat a b c))))))) (ert-deftest destructure-list-errors () (should-error (loopy--get-var-groups '(a b &rest)) :type 'loopy-&rest-missing) @@ -144,195 +108,216 @@ new values of the earlier variables." ;; (should-error (loopy--get-var-groups '(_ _)) ) ) -(ert-deftest destructure-lists () +;;;; `loopy-let*' + +;; `loopy-let*' is just a version of `pcase', so the individual +;; destructuring features are covered by `pcase'. We only need to +;; test that the macro expands correctly. + + +(ert-deftest loopy-let*-prev-val () + "Make sure we don't shadow values. +Later bindings can have access to the values of earlier bindings. +Later variables in the same destructuring should not use the +new values of the earlier variables." + (should (equal '(2 3 13 107) + (eval (quote (let ((a 1) + (b 2) + (c 7) + (d 33)) + (loopy-let* (((a b) (list (1+ a) (1+ b))) + (f (lambda (x) (+ 100 x))) + ([c d] (vector (+ 10 b) + (funcall f c)))) + (list a b c d)))) + t)))) + +;;;; Generalized variables + +;; This only tests the getting of values. +(ert-deftest destructure-lists-ref-values () (should (equal '(1 2 3) - (eval (quote (loopy-let* (((a b c) '(1 2 3))) + (eval (quote (loopy-ref (((a b c) '(1 2 3))) (list a b c)))))) - (should (equal '(1 2 3 (4 5)) - (eval (quote (loopy-let* (((a b c . d) '(1 2 3 4 5))) + (should (equal '(1 2 3 4) + (eval (quote (loopy-ref (((a b (c d)) '(1 2 (3 4)))) (list a b c d)))))) - (should (equal '(1 2 3 (4 5)) - (eval (quote (loopy-let* (((a b c &rest d) '(1 2 3 4 5))) + (should (equal '(1 2 3 4) + (eval (quote (loopy-ref (((a b &rest (c d)) '(1 2 3 4))) (list a b c d)))))) + (should (equal '(1 2 (3 4)) + (eval (quote (loopy-ref (((a b . c) '(1 2 3 4))) + (list a b c)))))) - (should (equal '(1 2 3 4 5) - (eval (quote (loopy-let* (((a b c &optional d e) '(1 2 3 4 5))) + (should (equal '(1 2 3 5 6) + (eval (quote (loopy-ref (((a b c &key d e) '(1 2 3 :e 6 :d 5))) (list a b c d e)))))) - (should (equal '(1 2 3 4 5 nil nil) - (eval (quote (loopy-let* (((a b c &optional d e (f nil f-supp)) '(1 2 3 4 5))) - (list a b c d e f f-supp)))))) - - (should (equal '(1 2 3 4 5 27 nil) - (eval (quote (loopy-let* (((a b c &optional d e (f 27 f-supp)) '(1 2 3 4 5))) - (list a b c d e f f-supp)))))) - - (should (equal '(1 2 3 4 5 6 t) - (eval (quote (loopy-let* (((a b c &optional d e (f 27 f-supp)) '(1 2 3 4 5 6))) - (list a b c d e f f-supp)))))) - - (should (equal '(1 2 3 4 5 6 t (7 8)) - (eval (quote (loopy-let* ((( a b c &optional d e (f 27 f-supp) - &rest g) - '(1 2 3 4 5 6 7 8))) - (list a b c d e f f-supp g)))))) - - (should (equal '(1 2 3 t) - (eval (quote (loopy-let* ((( a &optional ((b c) nil bc-supp)) - '(1 (2 3)))) - (list a b c bc-supp)))))) - - (should (equal '(1 77 88 nil) - (eval (quote (loopy-let* ((( a &optional ((b c) (list 77 88) bc-supp)) - '(1))) - (list a b c bc-supp)))))) - - (should (equal '(1 77 88 nil nil) - (eval (quote (loopy-let* ((( a &optional ((b &optional (c 88 c-supp)) - (list 77) - bc-supp)) - '(1))) - (list a b c bc-supp c-supp)))))) - - (should (equal '(1 2 3 4 5) - (eval (quote (loopy-let* (((a b c &key d e) '(1 2 3 :e 5 :d 4))) + (should (equal '(1 2 3 5 6) + (eval (quote (loopy-ref (((a b c &map (:d d) (:e e)) '(1 2 3 :e 6 :d 5))) (list a b c d e)))))) - (should (equal '(1 2 3 5 t 27 nil) - (eval (quote (loopy-let* (( (a b c &key (e nil e-supp) - (f 27 f-supp) - &allow-other-keys) - '(1 2 3 :e 5 :d 4))) - (list a b c e e-supp f f-supp)))))) - - (should (equal '(1 2 3 5 t nil nil) - (eval (quote (loopy-let* (((a b c &key - ((:elephant e) nil e-supp) - ((:fox f) nil f-supp) - &allow-other-keys) - '(1 2 3 :elephant 5 :d 4))) - (list a b c e e-supp f f-supp)))))) - - (should (equal '(1 2 3 4 5 (:e 5 :d 4)) - (eval (quote (loopy-let* (((a b c &key d e . f) '(1 2 3 :e 5 :d 4))) - (list a b c d e f)))))) - - (should (equal '(1 2 3 7 6 (:e 6 :d 7)) - (eval (quote (loopy-let* (((a b c _ _ &key d e . f) '(1 2 3 4 5 :e 6 :d 7))) - (list a b c d e f)))))) - - (should (equal '(1 2 3 7 6 (4 5 :e 6 :d 7) 5) - (eval (quote (loopy-let* (((a b c &key ((4 key4)) d e &rest f) - '(1 2 3 4 5 :e 6 :d 7))) - (list a b c d e f key4)))))) - - (should (equal '(1 2 3 7 6 (4 5 :e 6 :d 7) 5) - (eval (quote (loopy-let* (((a b c &rest f &key ((4 key4)) d e) - '(1 2 3 4 5 :e 6 :d 7))) - (list a b c d e f key4)))))) - - (should-error (eval (quote (loopy-let* (((&key d e) '(:a 7 :e 5 :d 4))) - (list d e a)))) - :type 'loopy-bad-run-time-destructuring) + (should (equal '(1 2 3 5 6 (:e 6 :d 5)) + (eval (quote (loopy-ref (((a b c &rest rest &key d e) + '(1 2 3 :e 6 :d 5))) + (list a b c d e rest)))))) + + (should (equal '(1 2 3 5 6 (:e 6 :d 5)) + (eval (quote (loopy-ref (((a b c &rest rest &map (:d d) (:e e)) + '(1 2 3 :e 6 :d 5))) + (list a b c d e rest)))))) + + (should (equal '(1 2 3 5 6 (:e 6 :d 5)) + (eval (quote (loopy-ref (((a b c &map (:d d) (:e e) . rest) + '(1 2 3 :e 6 :d 5))) + (list a b c d e rest)))))) + + (should (equal '(1 2 3 5 6 (:e 6 :d 5)) + (eval (quote (loopy-ref (((a b c &key d e &rest rest) + '(1 2 3 :e 6 :d 5))) + (list a b c d e rest)))))) - (should (equal '(4 5) - (eval (quote (loopy-let* (((&key d e &allow-other-keys) '(:a 7 :e 5 :d 4))) + (should (equal '(5 6) + (eval (quote (loopy-ref (((&key d e) '(1 2 :e 6 :d 5))) (list d e)))))) - (should (= 4 (eval (quote (loopy-let* (((_ _ _ a _ _ _) '(1 2 3 4 5 6 7))) - a)))))) - -;; We separate this since there's just way too many conditions in one test -;; otherwise. -(ert-deftest destructure-list-with-whole () - (should (equal '((1 2 3) 1 2 3) - (eval (quote (loopy-let* (((&whole cat a b c) '(1 2 3))) - (list cat a b c)))))) - - (should (equal '((1 2 3 4 5) 1 2 3 (4 5)) - (eval (quote (loopy-let* (((&whole cat a b c . d) '(1 2 3 4 5))) - (list cat a b c d)))))) - - (should (equal '((1 2 3 4 5) 1 2 3 (4 5)) - (eval (quote (loopy-let* (((&whole cat a b c &rest d) - '(1 2 3 4 5))) - (list cat a b c d)))))) - - (should (equal '((1 2 3 :e 5 :d 4) 1 2 3 4 5) - (eval (quote (loopy-let* (((&whole cat a b c &key d e) - '(1 2 3 :e 5 :d 4))) - (list cat a b c d e)))))) - - (should (equal '((1 2 3 :e 5 :d 4) 1 2 3 4 5 (:e 5 :d 4)) - (eval (quote (loopy-let* (((&whole cat a b c &key d e . f) - '(1 2 3 :e 5 :d 4))) - (list cat a b c d e f)))))) - - (should (equal '((1 2 3 4 5 :e 6 :d 7) 1 2 3 7 6 (4 5 :e 6 :d 7) 5) - (eval (quote (loopy-let* (((&whole cat a b c &key d e ((4 key4)). f) - '(1 2 3 4 5 :e 6 :d 7))) - (list cat a b c d e f key4)))))) - - (should (equal '((1 2 3 4 5 e 6 d 7) 1 2 3 7 6 (4 5 e 6 d 7)) - (eval (quote (loopy-let* (((&whole cat a b c &map d e . f) - '(1 2 3 4 5 e 6 d 7))) - (list cat a b c d e f)))))) - - (should (equal '((1 2 3 4 5 :e 6 :d 7) 1 2 3 7 6 (4 5 :e 6 :d 7)) - (eval (quote (loopy-let* (((&whole cat a b c &map (:d d) (:e e) . f) - '(1 2 3 4 5 :e 6 :d 7))) - (list cat a b c d e f)))))) - - (should (equal '((1 2 3 4 5 :e 6 :d 7) 1 2 3 7 6 (4 5 :e 6 :d 7) 5) - (eval (quote (loopy-let* (((&whole cat a b c &key d e ((4 key4)) &rest f) - '(1 2 3 4 5 :e 6 :d 7))) - (list cat a b c d e f key4)))))) - - (should (equal '((1 2 3 4 5 e 6 d 7) 1 2 3 7 6 (4 5 e 6 d 7)) - (eval (quote (loopy-let* (((&whole cat a b c &map d e &rest f) - '(1 2 3 4 5 e 6 d 7))) - (list cat a b c d e f)))))) - - (should (equal '((1 2 3 4 5 :e 6 :d 7) 1 2 3 7 6 (4 5 :e 6 :d 7) 5) - (eval (quote (loopy-let* (((&whole cat a b c &rest f &key d e ((4 key4))) - '(1 2 3 4 5 :e 6 :d 7))) - (list cat a b c d e f key4)))))) - - (should (equal '((1 2 3 4 5 :e 6 :d 7) 1 2 3 7 6 (4 5 :e 6 :d 7)) - (eval (quote (loopy-let* (((&whole cat a b c &rest f - &map (:d d) (:e e)) - '(1 2 3 4 5 :e 6 :d 7))) - (list cat a b c d e f)))))) - - (should (equal '((:a 7 :e 5 :d 4) 4 5) - (eval (quote (loopy-let* (((&whole cat &key d e &allow-other-keys) - '(:a 7 :e 5 :d 4))) - (list cat d e)))))) - - (should (equal '((:a 7 :e 5 :d 4 :allow-other-keys t) 4 5) - (eval (quote (loopy-let* (((&whole cat &key d e) - '(:a 7 :e 5 :d 4 :allow-other-keys t))) - (list cat d e))))))) + (should (equal '(5 6) + (eval (quote (loopy-ref (((&map d e) '(1 2 e 6 d 5))) + (list d e))))))) -;; This only tests the getting of values. -(ert-deftest destructure-lists-ref-values () - (should (equal '(1 2 3) - (eval (quote (loopy-ref (((a b c) '(1 2 3))) - (list a b c)))))) +(defmacro loopy-def-loopy-ref-test (base-name &rest args) + "Create variants of test BASE-NAME. + +The valid keys are: + +- `:doc': Documentation of the test. +- `:name': Name of the variant. +- `:val': Value to be destructured. +- `:var': Variables used in destructuring. +- `:do': How the destructuring should output. + By default, a list of the variables used in + destructuring in the order given in VAR. +- `:result': What the value of DO should be equal to. +- `:tests': A sequence of property lists containing + any of the above keys, which override + any values for the keys given outside + the property list. + +\(fn BASE-NAME &key DOC NAME VAL BAR RESULT PAT DO TESTS)" + (declare (indent 1)) + (cl-labels ((loopy--dpt-internal-expander (plist) + (if-let ((tests (plist-get plist :tests))) + (cons 'progn + (mapcar (let ((new-plist `( :tests nil ,@plist))) + (lambda (elt) + (loopy--dpt-internal-expander + (append elt new-plist)))) + tests)) + (map-let ((:base base) + (:doc doc) + (:name name) + (:val val) + (:var var) + (:result result) + (:pat pat) + (:do do)) + plist + `(ert-deftest ,(intern (concat (symbol-name base) "-" (symbol-name name))) + ,doc + () + (should (equal ,result + (eval (quote (let ,(cl-loop + for v in var + collect + `(,v 'loopy--intentionally-bad-val)) + (loopy-ref ((,pat ,val)) + ,(or do (cons 'list var))))) + t)))))))) + (let ((output (loopy--dpt-internal-expander (append (list :base base-name) + args)))) + (if (memq (car output) '(ert-deftest progn)) + output + (cons 'progn output))))) + + + +(loopy-def-loopy-ref-test destructure-seq-ref-values + :result (list 1 2 3) + :var (a b c) + :tests [( :val (list 1 2 3) + :tests [(:name list-as-list :pat (&seq a b c)) + (:name list-as-array :pat [&seq a b c])]) + ( :val (vector 1 2 3) + :tests [(:name vector-as-list :pat (&seq a b c)) + (:name vector-as-array :pat [&seq a b c])])]) + +(loopy-def-loopy-ref-test destructure-seq-ref-subseq-values + :result (list 1 2 3 4) + :var (a b c d) + :tests [( :val (list 1 2 (list 3 4)) + :tests [(:name list-in-list-as-list-1 :pat (&seq a b (c d))) + (:name list-in-list-as-array-1 :pat [&seq a b (c d)]) + (:name list-in-list-as-list-2 :pat (&seq a b (&seq c d))) + (:name list-in-list-as-array-2 :pat [&seq a b (&seq c d)]) + (:name list-in-list-as-list-3 :pat (&seq a b [&seq c d])) + (:name list-in-list-as-array-4 :pat [&seq a b [&seq c d]])]) + ( :val (list 1 2 (vector 3 4)) + :tests [(:name vector-in-list-as-list-1 :pat (&seq a b [c d])) + (:name vector-in-list-as-array-1 :pat [&seq a b [c d]]) + (:name vector-in-list-as-list-2 :pat (&seq a b (&seq c d))) + (:name vector-in-list-as-array-2 :pat [&seq a b (&seq c d)]) + (:name vector-in-list-as-list-3 :pat (&seq a b [&seq c d])) + (:name vector-in-list-as-array-4 :pat [&seq a b [&seq c d]])]) + ( :val (vector 1 2 (list 3 4)) + :tests [(:name list-in-vector-as-list-1 :pat (&seq a b (c d))) + (:name list-in-vector-as-array-1 :pat [&seq a b (c d)]) + (:name list-in-vector-as-list-2 :pat (&seq a b (&seq c d))) + (:name list-in-vector-as-array-2 :pat [&seq a b (&seq c d)]) + (:name list-in-vector-as-list-3 :pat (&seq a b [&seq c d])) + (:name list-in-vector-as-array-4 :pat [&seq a b [&seq c d]])]) + ( :val (vector 1 2 (vector 3 4)) + :tests [(:name vector-in-vector-as-list-1 :pat (&seq a b [c d])) + (:name vector-in-vector-as-array-1 :pat [&seq a b [c d]]) + (:name vector-in-vector-as-list-2 :pat (&seq a b (&seq c d))) + (:name vector-in-vector-as-array-2 :pat [&seq a b (&seq c d)]) + (:name vector-in-vector-as-list-3 :pat (&seq a b [&seq c d])) + (:name vector-in-vector-as-array-4 :pat [&seq a b [&seq c d]])])]) + +(ert-deftest pcase-for-iteration-unique-values () + "This condition was found during documentation writing." + (thread-last (loopy--pcase-destructure-for-iteration + '(loopy [&seq i j &optional k &rest r]) + 'val) + (cl-second) + (seq-group-by #'identity) + (map-every-p (lambda (_ val) (= 1 (length val)))))) + +(ert-deftest destructure-lists-ref-&seq-values () + (should (equal '(1 2 3 4) + (eval (quote (loopy-ref (((&seq a b (c d)) '(1 2 (3 4)))) + (list a b c d)))))) (should (equal '(1 2 3 4) - (eval (quote (loopy-ref (((a b (c d)) '(1 2 (3 4)))) + (eval (quote (loopy-ref (((&seq a b (&seq c d)) '(1 2 (3 4)))) (list a b c d)))))) (should (equal '(1 2 3 4) - (eval (quote (loopy-ref (((a b &rest (c d)) '(1 2 3 4))) + (eval (quote (loopy-ref (((&seq a b &rest (c d)) '(1 2 3 4))) (list a b c d)))))) (should (equal '(1 2 (3 4)) - (eval (quote (loopy-ref (((a b . c) '(1 2 3 4))) + (eval (quote (loopy-ref (((&seq a b . c) '(1 2 3 4))) + (list a b c)))))) + + (should (equal '(1 2 (3 4)) + (eval (quote (loopy-ref (((&seq a b &rest c) '(1 2 3 4))) + (list a b c)))))) + + (should (equal '(1 2 (3 4)) + (eval (quote (loopy-ref (([&seq a b &rest c] '(1 2 3 4))) (list a b c)))))) (should (equal '(1 2 3 5 6) @@ -358,6 +343,97 @@ new values of the earlier variables." (eval (quote (loopy-ref (((&key d e) '(1 2 :e 6 :d 5))) (list d e))))))) +(ert-deftest destructure-&seq-list-ref-setf () + (should (equal '(1 2 3) + (let ((l (list 7 7 7))) + (loopy-ref (((&seq a b c) l)) + (setf a 1 b 2 c 3) + l)))) + + (should (equal '(1 2 (3 4)) + (let ((l (list 7 7 (list 7 7)))) + (loopy-ref (((&seq a b (c d)) l)) + (setf a 1 b 2 c 3 d 4) + l)))) + + (should (equal '(1 2 (3 4)) + (let ((l (list 7 7 (list 7 7)))) + (loopy-ref (((&seq a b (&seq c d)) l)) + (setf a 1 b 2 c 3 d 4) + l)))) + + (should (equal '(1 2 3 4) + (let ((l (list 7 7 7 7))) + (loopy-ref (((&seq a b &rest (c d)) l)) + (setf a 1 b 2 c 3 d 4) + l)))) + + (should (equal '(1 2 3 4) + (let ((l (list 7 7 7 7))) + (loopy-ref (((&seq a b &rest (&seq c d)) l)) + (setf a 1 b 2 c 3 d 4) + l)))) + + ;; NOTE: This tests is not generic enough for seq.el: + ;; (should (equal '(1 2 . 3) + ;; (let ((l (list 7 7 7 7))) + ;; (loopy-ref (((&seq a b . c) l)) + ;; (setf a 1 b 2 c 3)) + ;; l))) + + (should (equal '(1 2 3 :d 4 :e 5) + (let ((l (list 7 7 7 :d 7 :e 7))) + (loopy-ref (((&seq a b c &map (:d d) (:e e)) l)) + (setf a 1 b 2 c 3 d 4 e 5)) + l))) + + (should (equal '(1 2 3 :e 10 :d 8) + (let ((l (list 7 7 7 :e 7 :d 7))) + (loopy-ref (((&seq a b c &rest rest &map (:d d) (:e e)) l)) + (setf a 1 b 2 c 3 d 4 e 5 + rest (mapcar (lambda (x) + (if (numberp x) + (* 2 x) + x)) + rest))) + l))) + + (should (equal '(1 2 3 :e 10 :d 8) + (let ((l (list 7 7 7 :e 7 :d 7))) + (loopy-ref (((&seq a b c &map (:d d) (:e e) . rest) l)) + (setf a 1 b 2 c 3 d 4 e 5 + rest (mapcar (lambda (x) + (if (numberp x) + (* 2 x) + x)) + rest))) + l))) + + (should (equal '(1 2 3 :e 10 :d 8) + (let ((l (list 7 7 7 :e 7 :d 7))) + (loopy-ref (((&seq a b c &map (:d d) (:e e) &rest rest) l)) + (setf a 1 b 2 c 3 d 4 e 5 + rest (mapcar (lambda (x) + (if (numberp x) + (* 2 x) + x)) + rest))) + l))) + + (should (equal '(7 7 :a 1 :b 2) + (let ((l (list 7 7 :a 7 :b 7))) + (loopy-ref (((&seq &map (:a a) (:b b)) l)) + (setf a 1 b 2)) + l))) + + (should (equal '(2 3) + (eval (quote + (let ((l (list 7 7))) + (loopy-ref (((&seq &whole whole a b) l)) + (setf a 1 b 2 + whole (mapcar #'1+ whole))) + l)))))) + ;; This tests the setting of values. (ert-deftest destructure-list-ref-setf () (should (equal '(1 2 3) @@ -456,6 +532,82 @@ new values of the earlier variables." (loopy-generalized-supplied t)))) +(ert-deftest destructure-&seq-array-refs () + (should (equal [1 2 3] + (let ((arr [7 7 7])) + (loopy-ref (([&seq a b c] arr)) + (setf a 1 b 2 c 3)) + arr))) + + ;; FIXME: This won't work until we implement the recursive setters. + ;; (should (equal [1 2 3] + ;; (let ((arr [7 7 7 27])) + ;; (loopy-ref (([&seq a b c &map [0 d]] arr)) + ;; (setf a 1 b 2 c 3 d 99)) + ;; arr))) + + (should (equal [2 3 4] + (let ((arr [7 7 7])) + (loopy-ref (([&seq &whole whole a b c] arr)) + (setf a 1 b 2 c 3 + whole (cl-map 'vector #'1+ whole))) + arr))) + + (should (equal [1 2 3 [4 5]] + (let ((arr [7 7 7 [7 7]])) + (loopy-ref (([&seq a b c [d e]] arr)) + (setf a 1 b 2 c 3 d 4 e 5)) + arr))) + + (should (equal [1 2 3 [4 5]] + (let ((arr [7 7 7 [7 7]])) + (loopy-ref (([&seq a b c [&seq d e]] arr)) + (setf a 1 b 2 c 3 d 4 e 5)) + arr))) + + (should (equal [1 2 3 [4 5]] + (let ((arr [7 7 7 [7 7]])) + (loopy-ref (([&seq a b c (&seq d e)] arr)) + (setf a 1 b 2 c 3 d 4 e 5)) + arr))) + + ;; TODO: This test currently doesn't pass due to Elisp limitations. + ;; (should (equal [1 2 3 4 5] + ;; (eval (quote + ;; (let ((arr [7 7 7 7 7])) + ;; (loopy-ref (([a b c &rest [d e]] arr)) + ;; (setf a 1 b 2 c 3 d 4 e 5)) + ;; arr))))) + + ;; NOTE: Setting a variable after `&rest' in an array will not truncate the array. + (should (equal [1 2 3 4 7] + (let ((arr [7 7 7 7 7])) + (loopy-ref (([&seq a b c &rest d] arr)) + (setf a 1 b 2 c 3 d [4])) + arr))) + + (should (equal [1 2 3 4 7] + (let ((arr [7 7 7 7 7])) + (loopy-ref (([&seq a b c &rest d] arr)) + (setf a 1 b 2 c 3 d [4])) + arr))) + + ;; NOTE: This currently doesn't work due to upstream implementations. + ;; See issue #184. + ;; (should (equal [1 2 3 4 0 0 16] + ;; (let ((arr (vector 7 7 7 7 0 0 6))) + ;; (loopy-ref (([&seq a b c &rest d &map (3 sub-idx-3)] arr)) + ;; (setf a 1 b 2 c 3 d [4]) + ;; (cl-incf sub-idx-3 10)) + ;; arr))) + + (should (equal [2 3] + (let ((arr [7 7])) + (loopy-ref (([&seq &whole cat a b] arr)) + (setf a 1 b 2 + cat (cl-map 'vector #'1+ cat))) + arr)))) + (ert-deftest destructure-array-refs () (should (equal [1 2 3] (let ((arr [7 7 7])) @@ -611,6 +763,7 @@ new values of the earlier variables." (finally-return i j k rest k1 k2))))))) ;;;;; Pcase Pattern +(define-error 'loopy-pcase-no-match "No match found.") (defmacro loopy--pcase-exhaustive-wrapper (vars val &rest branches) "Wrap variables to make sure that they're bound on earlier versions of Emacs. @@ -620,116 +773,1081 @@ Prior to Emacs 28, `pcase' didn't guarantee binding all variables. - VAL is the value to match against. - BRANCHES are the `pcase' branches." (declare (indent 2)) - `(eval (quote (let ,(mapcar (lambda (v) - `(,v 'intentionally-bad-test-val)) - vars) - (pcase-exhaustive ,val - ,@branches))) - t)) + `(let ,(mapcar (lambda (v) + `(,v 'intentionally-bad-test-val)) + vars) + (or (pcase ,val + ,@branches) + (signal 'loopy-pcase-no-match + (quote (,val ,@branches))))) + ;; `(eval (quote (let ,(mapcar (lambda (v) + ;; `(,v 'intentionally-bad-test-val)) + ;; vars) + ;; (pcase ,val + ;; ,@branches + ;; (_ (signal 'loopy-pcase-no-match + ;; (quote (,val ,@branches))))))) + ;; t) + ) -(ert-deftest pcase-tests-loopy-&whole-should-error () - "`&whole' must come first if given, and must be followed by a patter." +(defun loopy--pcase-convert (seq type &optional recursive) + "Convert SEQ into TYPE, optionally RECURSIVE." + (seq-into (seq-map (lambda (x) + (if (and recursive (seqp x)) + (loopy--pcase-convert x type recursive) + x)) + seq) + type)) + +(cl-defmacro loopy-def-pcase-test (name &key doc result pat do var val + vector-result + list-result + (error nil) + (convert t) + (list t) + (seq t) + (seq-vector 1) + (vector t) + ) + "Create variant of test. + +- ERROR is whether it should error. +- RESULT is the output for `equal.' +- PAT is the pattern for `(loopy PAT)' +- DO is the last expression in the `pcase' branch +- VAR is a list of variables to be set during the test. +- VAL is the matched value +- CONVERT means convert VAL to the tested type. If `recursive' + then also convert the subsequences in the pattern and the result. +- LIST, SEQ, and VECTOR are the kinds of sequences to convert into. + SEQ-VECTOR means to ignore the vector version of the `&seq' pattern." + (declare (indent 1)) + (let ((do (or do `(list ,@var))) + (str-name (symbol-name name))) + `(progn + ,(when list + `(ert-deftest ,(intern (concat str-name "-list")) () + ,doc + ,(let ((body `(loopy--pcase-exhaustive-wrapper ,var + ,(if convert + `(loopy--pcase-convert ,val 'list ,(eq convert 'recursive)) + val) + ((loopy ,(loopy--pcase-convert pat 'list (eq convert 'recursive))) + ,do)))) + (if error + `(should-error ,body :type 'loopy-pcase-no-match) + `(should (equal ,(or list-result result) ,body)))))) + + ,(when vector + `(ert-deftest ,(intern (concat str-name "-vector")) () + ,doc + ,(let ((body `(loopy--pcase-exhaustive-wrapper ,var + ,(if convert + `(loopy--pcase-convert ,val 'vector ,(eq convert 'recursive)) + val) + ((loopy ,(loopy--pcase-convert pat 'vector (eq convert 'recursive))) + ,do)))) + (if error + `(should-error ,body :type 'loopy-pcase-no-match) + `(should (equal ,(or vector-result result) ,body)))))) + + ,(when seq + (let ((new-pat (if (listp pat) + (cons '&seq pat) + (vconcat [&seq] pat)))) + `(progn + (ert-deftest ,(intern (concat str-name "-&seq-list-as-list")) () + ,doc + ,(let ((body `(loopy--pcase-exhaustive-wrapper ,var + ,(if convert + `(loopy--pcase-convert ,val 'list ,(eq convert 'recursive)) + val) + ((loopy ,(loopy--pcase-convert new-pat 'list (eq convert 'recursive))) + ,do)))) + (if error + `(should-error ,body :type 'loopy-pcase-no-match) + `(should (equal ,(or list-result result) ,body))))) + + (ert-deftest ,(intern (concat str-name "-&seq-vector-as-list")) () + ,doc + ,(let ((body `(loopy--pcase-exhaustive-wrapper ,var + ,(if convert + `(loopy--pcase-convert ,val 'vector ,(eq convert 'recursive)) + val) + ((loopy ,(loopy--pcase-convert new-pat 'list (eq convert 'recursive))) + ,do)))) + (if error + `(should-error ,body :type 'loopy-pcase-no-match) + `(should (equal ,(or vector-result result) ,body))))) + + ,(when seq-vector + `(progn + (ert-deftest ,(intern (concat str-name "-&seq-list-as-vector")) () + ,doc + ,(let ((body `(loopy--pcase-exhaustive-wrapper ,var + ,(if convert + `(loopy--pcase-convert ,val 'list ,(eq convert 'recursive)) + val) + ((loopy ,(loopy--pcase-convert new-pat 'vector (eq convert 'recursive))) + ,do)))) + (if error + `(should-error ,body :type 'loopy-pcase-no-match) + `(should (equal ,(or list-result result) ,body))))) + + (ert-deftest ,(intern (concat str-name "-&seq-vector-as-vector")) () + ,doc + ,(let ((body `(loopy--pcase-exhaustive-wrapper ,var + ,(if convert + `(loopy--pcase-convert ,val 'vector ,(eq convert 'recursive)) + val) + ((loopy ,(loopy--pcase-convert new-pat 'vector (eq convert 'recursive))) + ,do)))) + (if error + `(should-error ,body :type 'loopy-pcase-no-match) + `(should (equal ,(or vector-result result) ,body))))))))))))) + +(push (list "Loopy Pcase Tests" + (rx (0+ blank) + "(loopy-def-pcase-test" + (0+ (or (syntax symbol) (syntax word))) + (1+ (syntax whitespace)) + (group-n 1 (1+ (or word (syntax symbol))))) + 1) + imenu-generic-expression) + +(defmacro loopy-def-pcase-test3 (base-name &rest args) + "Create variants of test BASE-NAME. + +The valid keys are: + +- `:doc': Documentation of the test. +- `:name': Name of the variant. +- `:val': Value to be destructured. +- `:var': Variables used in destructuring. +- `:do': How the destructuring should output. + By default, a list of the variables used in + destructuring in the order given in VAR. +- `:result': What the value of DO should be equal to. +- `:tests': A sequence of property lists containing + any of the above keys, which override + any values for the keys given outside + the property list. + +\(fn BASE-NAME &key DOC NAME VAL BAR RESULT PAT DO TESTS)" + (declare (indent 1)) + (cl-labels ((loopy--dpt-internal-expander (plist) + (if-let ((tests (plist-get plist :tests))) + (cons 'progn + (mapcar (let ((new-plist `( :tests nil ,@plist))) + (lambda (elt) + (loopy--dpt-internal-expander + (append elt new-plist)))) + tests)) + (map-let ((:base base) + (:doc doc) + (:name name) + (:val val) + (:var var) + (:result result) + (:pat pat) + (:do do)) + plist + `(ert-deftest ,(intern (concat (symbol-name base) "-" (symbol-name name))) + ,doc + () + (should (equal ,result + (loopy--pcase-exhaustive-wrapper + ,var + ,val + ((loopy + ,pat) + ,(or do (cons 'list var))))))))))) + (let ((output (loopy--dpt-internal-expander (append (list :base base-name) + args)))) + (if (memq (car output) '(ert-deftest progn)) + output + (cons 'progn output))))) + +(ert-deftest pcase-tests-loopy-&seq-should-error () + "`&seq' must come first if given, and must be followed by a patter." (should-error (loopy--pcase-exhaustive-wrapper (a b c) (list 1 2 3) - ((loopy (&whole)) + ((loopy (&seq)) (list a b c))) - :type 'loopy-&whole-missing) + :type 'loopy-bad-desctructuring) (should-error (loopy--pcase-exhaustive-wrapper (a b c) (list 1 2 3) - ((loopy (&whole &rest)) + ((loopy (&seq &rest)) (list a b c))) - :type 'loopy-&whole-missing) + :type 'loopy-bad-desctructuring) (should-error (loopy--pcase-exhaustive-wrapper (a b c) (list 1 2 3) - ((loopy (&whole _ &rest)) + ((loopy (a b &seq c)) (list a b c))) - :type 'loopy-&whole-missing) + :type 'loopy-&seq-bad-position) (should-error (loopy--pcase-exhaustive-wrapper (a b c) (list 1 2 3) - ((loopy (a b &whole c)) + ((loopy (&whole a &seq c)) (list a b c))) - :type 'loopy-&whole-bad-position) + :type 'loopy-&seq-bad-position) (should-error (loopy--pcase-exhaustive-wrapper (a b c) (list 1 2 3) - ((loopy (&rest a &whole c)) + ((loopy (&rest a &seq c)) (list a b c))) - :type 'loopy-&whole-bad-position) + :type 'loopy-&seq-bad-position) (should-error (loopy--pcase-exhaustive-wrapper (a b c) (list 1 2 3) - ((loopy (&key a &whole c)) + ((loopy (&key a &seq c)) (list a b c))) - :type 'loopy-&whole-bad-position) + :type 'loopy-&seq-bad-position) (should-error (loopy--pcase-exhaustive-wrapper (a b c) (list 1 2 3) - ((loopy (&aux (a 1) &whole c)) + ((loopy (&aux (a 1) &seq c)) (list a b c))) - :type 'loopy-&whole-bad-position) + :type 'loopy-&seq-bad-position) (should-error (loopy--pcase-exhaustive-wrapper (a b c) (list 1 2 3) - ((loopy (&optional (a 1) &whole c)) + ((loopy (&optional (a 1) &seq c)) (list a b c))) - :type 'loopy-&whole-bad-position) + :type 'loopy-&seq-bad-position) - (should-error (loopy--pcase-exhaustive-wrapper (whole1 whole2) + (should-error (loopy--pcase-exhaustive-wrapper (seq1 seq2) (list 1 2 3) - ((loopy (&whole whole1 &whole whole2)) - (list whole1 whole2))) - :type 'loopy-&whole-bad-position)) + ((loopy (&seq seq1 &seq seq2)) + (list seq1 seq2))) + :type 'loopy-&seq-bad-position)) + +(loopy-def-pcase-test pcase-tests-loopy-pos-1 + :doc "Positional variables must match the length or less of EXPVAL." + :result (list 1 2 3) + :val (list 1 2 3) + :var (a b c) + :pat (a b c) + :do (list a b c)) + +(loopy-def-pcase-test pcase-tests-loopy-pos-2 + :doc "Positional variables must match the length or less of EXPVAL." + :error t + :val (list 1) + :var (a b) + :pat (a b)) + +(loopy-def-pcase-test pcase-tests-loopy-pos-3 + :doc "Positional variables must match the length or less of EXPVAL." + :result (list 1 2 3) + :val (list 1 2 3 4) + :var (a b c) + :pat (a b c)) -(ert-deftest pcase-tests-loopy-&whole () - "`&whole' can be a `pcase' pattern." - (should (equal (list (list 1 2 3) 1 2 3) - (loopy--pcase-exhaustive-wrapper (whole a b c) - (list 1 2 3) - ((loopy (&whole whole a b c)) - (list whole a b c))))) - - (should (equal (list 1 2 3 1 2 3) - (loopy--pcase-exhaustive-wrapper (a0 b0 c0 a b c) - (list 1 2 3) - ((loopy (&whole `(,a0 ,b0 ,c0) a b c)) - (list a0 b0 c0 a b c)))))) - -(ert-deftest pcase-tests-loopy-pos () - "Positional variables must match the length of EXPVAL." - (should (equal (list 1 2 3) - (loopy--pcase-exhaustive-wrapper (a b c) - (list 1 2 3) - ((loopy (a b c)) - (list a b c))))) - - (should (equal nil - (loopy--pcase-exhaustive-wrapper (a b) - (list (list 1)) - ((loopy (a b)) (list a b)) - (_ nil)))) +(ert-deftest pcase-tests-loopy-pos-sub-seq () + (should (equal (list 1 2 3 4) + (loopy--pcase-exhaustive-wrapper (a b c d) + (list 1 2 (vector 3 4)) + ((loopy (&seq a b (&seq c d))) + (list a b c d))))) - (should (equal nil - (loopy--pcase-exhaustive-wrapper (a b) - (list (list 1 2 3)) - ((loopy (a b)) (list a b)) - (_ nil))))) + (should (equal (list 1 2 3 4) + (loopy--pcase-exhaustive-wrapper (a b c d) + (vector 1 2 (list 3 4)) + ((loopy (&seq a b [&seq c d])) + (list a b c d))))) -(ert-deftest pcase-tests-loopy-pos-sub-seq () (should (equal (list 1 2 3 4) (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2 (list 3 4)) - ((loopy (a b (c d))) + (vector 1 2 (vector 3 4)) + ((loopy [&seq a b (&seq c d)]) (list a b c d))))) + (should (equal (list 1 2) + (loopy--pcase-exhaustive-wrapper (a b) + (list (vector 1 2)) + ((loopy (&seq (&seq a b))) + (list a b))))) + + (should (equal (list 1 2) + (loopy--pcase-exhaustive-wrapper (a b) + (vector (list 1 2)) + ((loopy (&seq [&seq a b])) + (list a b))))) + + (should (equal (list 1 2) + (loopy--pcase-exhaustive-wrapper (a b) + (vector (vector 1 2)) + ((loopy [&seq (&seq a b)]) + (list a b))))) + (should (equal (list 1 2) (loopy--pcase-exhaustive-wrapper (a b) (list (list 1 2)) - ((loopy ((a b))) + ((loopy [&seq [&seq a b]]) + (list a b)))))) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-1 + :val (list 1 2 3) + :result (list 1 2 3) + :var (a b c) + :pat (a b &optional c) + :do (list a b c)) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-2 + :val (list 1 2) + :result (list 1 2 nil) + :var (a b c) + :pat (a b &optional c) + :do (list a b c)) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-3 + :val (list 1 2) + :result (list 1 2 13) + :var (a b c) + :pat (a b &optional (c 13)) + :do (list a b c)) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-4 + :val (list 1 2) + :result (list 1 2 13) + :var (a b c) + :pat (a b &optional [c 13]) + :do (list a b c)) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-5 + :val (list 1 2) + :result (list 1 2 13 nil) + :var (a b c c-supplied) + :pat (a b &optional (c 13 c-supplied))) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-6 + :val (list 1 2 3) + :result (list 1 2 3 t) + :var (a b c c-supplied) + :pat (a b &optional [c 13 c-supplied])) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-ignored-1 + :result (list 1 2 nil) + :val (list 1 2) + :var (a b d) + :pat (a b &optional _ d)) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-ignored-2 + :result (list 1 2) + :val (list 1 2) + :var (a b) + :pat (a b &optional _ _)) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-ignored-3 + :result (list 1 2 13 nil) + :val (list 1 2) + :var (a b k1 k2) + :pat (a b &optional _ _ &key [k1 13] k2) + :vector nil + :seq nil) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-ignored-4 + :result (list 1 2 nil 14 nil) + :val (list 1 2) + :var (a b e k1 k2) + :pat (a b &optional _ _ &rest e &key [k1 14] k2) + :vector nil + :seq nil) + +(loopy-def-pcase-test pcase-tests-loopy-&optional-ignored-5 + :result (list 1 2 nil 14 nil) + :val (list 1 2) + :var (a b e k1 k2) + :pat (a b &optional _ _ &rest e &map [:k1 k1 14] (:k2 k2)) + :vector nil + :convert nil) + +;; FIXME: This test fails on Emacs 27 because the tests don't install the +;; correct version of Map.el. +(when (> emacs-major-version 27) + (loopy-def-pcase-test pcase-tests-loopy-&optional-ignored-6 + :result (list 1 2 [] 14 nil) + :val (vector 1 2) + :var (a b e k1 k2) + :pat [a b &optional _ _ &rest e &map [:k1 k1 14] (:k2 k2)] + :list nil + :convert nil)) + +(loopy-def-pcase-test pcase-tests-loopy-&whole-1 + :result (list (list 1 2 3) 1 2 3) + :val (list 1 2 3) + :var (whole a b c) + :pat (&whole whole a b c) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&whole-2 + :result (list (vector 1 2 3) 1 2 3) + :val (vector 1 2 3) + :var (whole a b c) + :pat (&whole whole a b c) + :list nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&whole-3 + :result (list 1 2 3 1 2 3) + :val (vector 1 2 3) + :var (a0 b0 c0 a b c) + :pat (&whole `[,a0 ,b0 ,c0] a b c) + :list nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&whole-4 + :result (list 1 2 3 1 2 3) + :val (list 1 2 3) + :var (a0 b0 c0 a b c) + :pat (&whole `(,a0 ,b0 ,c0) a b c) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&whole-5 + :result (list 1 2 3 1 2 3) + :val (vector 1 2 3) + :var (a0 b0 c0 a b c) + :pat (&whole (loopy (&seq a0 b0 c0)) a b c) + :vector nil) + +(loopy-def-pcase-test3 pcase-tests-loopy-pos-sub-seq-1 + :var (a b c d) + :result (list 1 2 3 4) + :tests [( :val (list 1 2 (list 3 4)) + :tests [(:name list-1 :pat (a b (c d))) + (:name list-2 :pat (a b (&seq c d))) + (:name list-3 :pat (a b [&seq c d])) + (:name seq-list-as-list-1 :pat (&seq a b (c d))) + (:name seq-list-as-list-2 :pat (&seq a b (&seq c d))) + (:name seq-list-as-list-3 :pat (&seq a b [&seq c d])) + (:name seq-list-as-vector-1 :pat [&seq a b (c d)]) + (:name seq-list-as-vector-2 :pat [&seq a b (&seq c d)]) + (:name seq-list-as-vector-3 :pat [&seq a b [&seq c d]])]) + ( :val (vector 1 2 (vector 3 4)) + :tests [(:name vector-1 :pat [a b [c d]]) + (:name vector-2 :pat [a b (&seq c d)]) + (:name vector-3 :pat [a b [&seq c d]]) + (:name seq-vector-as-list-1 :pat (&seq a b [c d])) + (:name seq-vector-as-list-2 :pat (&seq a b (&seq c d))) + (:name seq-vector-as-list-3 :pat (&seq a b [&seq c d])) + (:name seq-vector-as-vector-1 :pat [&seq a b [c d]]) + (:name seq-vector-as-vector-2 :pat [&seq a b (&seq c d)]) + (:name seq-vector-as-vector-3 :pat [&seq a b [&seq c d]])])]) + + +(loopy-def-pcase-test3 pcase-tests-loopy-pos-sub-seq-2 + :var (a b) + :result (list 1 2) + :tests [( :val (list (list 1 2)) + :tests [(:name list-in-list-1 :pat ((a b))) + (:name seq-list-in-list-as-list-1 :pat (&seq (a b))) + (:name seq-list-in-list-as-list-2 :pat ((&seq a b))) + (:name seq-list-in-list-as-list-3 :pat (&seq (&seq a b))) + (:name seq-list-in-list-as-list-4 :pat (&seq [&seq a b])) + (:name seq-list-in-list-as-vector-1 :pat [&seq (a b)]) + (:name seq-list-in-list-as-vector-2 :pat [&seq (&seq a b)]) + (:name seq-list-in-list-as-vector-3 :pat [&seq [&seq a b]])]) + ( :val (list (vector 1 2)) + :tests [(:name vector-in-list-1 :pat ([a b])) + (:name seq-vector-in-list-as-list-1 :pat (&seq [a b])) + (:name seq-vector-in-list-as-list-2 :pat ((&seq a b))) + (:name seq-vector-in-list-as-list-3 :pat (&seq (&seq a b))) + (:name seq-vector-in-list-as-list-4 :pat (&seq [&seq a b])) + (:name seq-vector-in-list-as-vector-1 :pat [&seq [a b]]) + (:name seq-vector-in-list-as-vector-2 :pat [&seq (&seq a b)]) + (:name seq-vector-in-list-as-vector-3 :pat [&seq [&seq a b]])]) + ( :val (vector (list 1 2)) + :tests [(:name list-in-vector-1 :pat [(a b)]) + (:name seq-list-in-vector-as-list-1 :pat (&seq (a b))) + (:name seq-list-in-vector-as-list-2 :pat [(&seq a b)]) + (:name seq-list-in-vector-as-list-3 :pat (&seq (&seq a b))) + (:name seq-list-in-vector-as-list-4 :pat (&seq [&seq a b])) + (:name seq-list-in-vector-as-vector-1 :pat [&seq (a b)]) + (:name seq-list-in-vector-as-vector-2 :pat [&seq (&seq a b)]) + (:name seq-list-in-vector-as-vector-3 :pat [&seq [&seq a b]])]) + ( :val (vector (vector 1 2)) + :tests [(:name vector-in-vector-1 :pat [[a b]]) + (:name seq-vector-in-vector-as-list-1 :pat (&seq [a b])) + (:name seq-vector-in-vector-as-list-2 :pat [(&seq a b)]) + (:name seq-vector-in-vector-as-list-3 :pat (&seq (&seq a b))) + (:name seq-vector-in-vector-as-list-4 :pat (&seq [&seq a b])) + (:name seq-vector-in-vector-as-vector-1 :pat [&seq [a b]]) + (:name seq-vector-in-vector-as-vector-2 :pat [&seq (&seq a b)]) + (:name seq-vector-in-vector-as-vector-3 :pat [&seq [&seq a b]])])]) + +;; NOTE: These tests disabled while we figure out how we want this to +;; behave. +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-1 +;; :result (list 1 2 3 4) +;; :val (list 1 2 (list 3 4)) +;; :var (a b c d) +;; :pat (a b &optional ((c d)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-2 +;; :result (list 1 2 3 4) +;; :val (list 1 2 (list 3 4)) +;; :var (a b c d) +;; :pat (a b &optional [(c d)])) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-3 +;; :result (list 1 2 3 4) +;; :val (list 1 2 (list 3 4)) +;; :var (a b c d) +;; :pat (a b &optional ((&seq c d)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-4 +;; :result (list 1 2 3 4) +;; :val (list 1 2 (list 3 4)) +;; :var (a b c d) +;; :pat (a b &optional [(&seq c d)])) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-5 +;; :result (list 1 2 nil nil) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional [(c d)])) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-6 +;; :result (list 1 2 nil nil) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional ((c d)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-7 +;; :result (list 1 2 nil nil) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional ((&seq c d)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-8 +;; :result (list 1 2 13 14) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional ((c d) (list 13 14)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-9 +;; :result (list 1 2 13 14) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional ([c d] (vector 13 14)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-10 +;; :result (list 1 2 13 14) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional ((&seq c d) (list 13 14)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-11 +;; :result (list 1 2 13 14) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional ([&seq c d] (list 13 14)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-12 +;; :result (list 1 2 13 14) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional ((c &optional (d 14)) (list 13)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-13 +;; :result (list 1 2 13 14) +;; :val (list 1 2) +;; :var (a b c d) +;; :pat (a b &optional ([c &optional (d 14)] (vector 13)))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-14 +;; :result (list 1 2 13 14 nil) +;; :val (list 1 2) +;; :var (a b c d cd-supplied) +;; :pat (a b &optional ((&seq c d) (list 13 14) cd-supplied))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-15 +;; :result (list 1 2 13 14 nil) +;; :val (list 1 2) +;; :var (a b c d cd-supplied) +;; :pat (a b &optional ((c d) (list 13 14) cd-supplied))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-16 +;; :result (list 1 2 13 14 nil) +;; :val (list 1 2) +;; :var (a b c d cd-supplied) +;; :pat (a b &optional ([c d] (vector 13 14) cd-supplied))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-17 +;; :result (list 1 2 13 14 nil t nil) +;; :val (list 1 2) +;; :var (a b c d cd-supplied c-sub-sup d-sub-sup) +;; :pat (a b &optional ((&optional (c 27 c-sub-sup) (d 14 d-sub-sup)) +;; (list 13) +;; cd-supplied))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-18 +;; :result (list 1 2 13 14 nil t nil) +;; :val (list 1 2) +;; :var (a b c d cd-supplied c-sub-sup d-sub-sup) +;; :pat (a b &optional ([&optional (c 27 c-sub-sup) (d 14 d-sub-sup)] +;; (vector 13) +;; cd-supplied))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-19 +;; :result (list 1 2 13 14 nil t nil) +;; :val (list 1 2) +;; :var (a b c d cd-supplied c-sub-sup d-sub-sup) +;; :pat (a b &optional ([&seq &optional (c 27 c-sub-sup) (d 14 d-sub-sup)] +;; (vector 13) +;; cd-supplied))) +;; +;; (loopy-def-pcase-test pcase-tests-loopy-&optional-sub-seq-20 +;; :result (list 1 2 13 14 nil t nil) +;; :val (list 1 2) +;; :var (a b c d cd-supplied c-sub-sup d-sub-sup) +;; :pat (a b &optional ((&seq &optional (c 27 c-sub-sup) [d 14 d-sub-sup]) +;; (vector 13) +;; cd-supplied))) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-ignored-1 + :result (list 1 2) + :val (list 1 2 3) + :var (a b) + :pat (a b &rest _)) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-ignored-2 + :result (list 1 2 3 11 12) + :val '(1 2 3 :k1 11 :k2 12) + :var (a b c k1 k2) + :pat (a b c &rest _ &map (:k1 k1) (:k2 k2)) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-ignored-3 + :result (list 1 2 3 11 12) + :val '(1 2 3 :k1 11 :k2 12) + :var (a b c k1 k2) + :pat (a b c &rest _ &key (k1 :k1) (k2 :k2)) + :vector nil + :seq nil) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-nonlist-cdr-1 + :result (list 1 2) + :val (cons 1 2) + :var (a b) + :pat (a &rest b) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-nonlist-cdr-2 + :result (list 1 2) + :val (cons 1 2) + :var (a b) + :pat (a &body b) + :vector nil + :convert nil) + +(ert-deftest pcase-tests-loopy-&rest-nonlist-cdr-3 () + (should (equal (list 1 2) + (loopy--pcase-exhaustive-wrapper (a b) + (cons 1 2) + ((loopy (a . b)) + (list a b))))) + + (should (equal (list 1 2) + (loopy--pcase-exhaustive-wrapper (a b) + (cons 1 2) + ;; This works for the list form of `&seq' because it is still + ;; an improper list for `loopy--get-var-groups'. + ((loopy (&seq a . b)) + (list a b)))))) + +(loopy-def-pcase-test3 pcase-tests-loopy-&rest-with-&whole-1 + :var (whole a b) + :tests [( :val (list 1 2) + :result (list (list 1 2) 1 (list 2)) + :tests [(:name list :pat (&whole whole a &body b)) + (:name seq-list-as-list-1 :pat (&seq &whole whole a &body b)) + (:name seq-list-as-list-2 :pat (&seq &whole whole a &body b)) + (:name seq-list-as-list-3 :pat (&seq &whole whole a &body b)) + (:name seq-list-as-vector-1 :pat [&seq &whole whole a &body b]) + (:name seq-list-as-vector-2 :pat [&seq &whole whole a &body b]) + (:name seq-list-as-vector-3 :pat [&seq &whole whole a &body b])]) + ( :val (vector 1 2) + :result (list (vector 1 2) 1 (vector 2)) + :tests [(:name vector :pat [&whole whole a &body b]) + (:name seq-vector-as-vector-1 :pat [&seq &whole whole a &body b]) + (:name seq-vector-as-vector-2 :pat [&seq &whole whole a &body b]) + (:name seq-vector-as-vector-3 :pat [&seq &whole whole a &body b]) + (:name seq-vector-as-list-1 :pat (&seq &whole whole a &body b)) + (:name seq-vector-as-list-2 :pat (&seq &whole whole a &body b)) + (:name seq-vector-as-list-3 :pat (&seq &whole whole a &body b))])]) + +(loopy-def-pcase-test3 pcase-tests-loopy-&rest-with-&whole-2 + :var (whole a b) + :tests [( :val (list 1 2) + :result (list (list 1 2) 1 (list 2)) + :tests [(:name list :pat (&whole whole a &rest b)) + (:name seq-list-as-list-1 :pat (&seq &whole whole a &rest b)) + (:name seq-list-as-list-2 :pat (&seq &whole whole a &rest b)) + (:name seq-list-as-list-3 :pat (&seq &whole whole a &rest b)) + (:name seq-list-as-vector-1 :pat [&seq &whole whole a &rest b]) + (:name seq-list-as-vector-2 :pat [&seq &whole whole a &rest b]) + (:name seq-list-as-vector-3 :pat [&seq &whole whole a &rest b])]) + ( :val (vector 1 2) + :result (list (vector 1 2) 1 (vector 2)) + :tests [(:name vector :pat [&whole whole a &rest b]) + (:name seq-vector-as-vector-1 :pat [&seq &whole whole a &rest b]) + (:name seq-vector-as-vector-2 :pat [&seq &whole whole a &rest b]) + (:name seq-vector-as-vector-3 :pat [&seq &whole whole a &rest b]) + (:name seq-vector-as-list-1 :pat (&seq &whole whole a &rest b)) + (:name seq-vector-as-list-2 :pat (&seq &whole whole a &rest b)) + (:name seq-vector-as-list-3 :pat (&seq &whole whole a &rest b))])]) + +(ert-deftest pcase-tests-loopy-&rest-with-&whole-3 () + (should (equal (list 1 2) + (loopy--pcase-exhaustive-wrapper (a b) + (cons 1 2) + ((loopy (a . b)) + (list a b))))) + + (should (equal (list 1 2) + (loopy--pcase-exhaustive-wrapper (a b) + (cons 1 2) + ;; This works for the list form of `&seq' because it is still + ;; an improper list for `loopy--get-var-groups'. + ((loopy (&seq a . b)) (list a b)))))) +(loopy-def-pcase-test pcase-tests-loopy-&rest-only-1 + :doc "Using only `&rest' should work like `&whole'." + :list-result (list (list 1 2)) + :vector-result (list (vector 1 2)) + :val (list 1 2) + :var (a) + :pat (&rest a)) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-only-2 + :doc "Using only `&rest' should work like `&whole'." + :list-result (list (list 1 2)) + :vector-result (list (vector 1 2)) + :val (list 1 2) + :var (a) + :pat (&body a)) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-after-&optional-1 + :result (list 1 2 3 (list 4 5)) + :val (list 1 2 3 4 5) + :var (a b c d) + :pat (&optional a b c &rest d) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-after-&optional-2 + :list-result (list 1 2 3 (list 4 5)) + :vector-result (list 1 2 3 (vector 4 5)) + :val (list 1 2 3 4 5) + :var (a b c d) + :pat (&optional a b c &body d)) + +(ert-deftest pcase-tests-loopy-&rest-after-&optional-3 () + (should (equal (list 1 2 3 (list 4 5)) + (loopy--pcase-exhaustive-wrapper (a b c d) + (list 1 2 3 4 5) + ((loopy (&optional a b c . d)) + (list a b c d))))) + + (should (equal (list 1 2 3 (list 4 5)) + (loopy--pcase-exhaustive-wrapper (a b c d) + (list 1 2 3 4 5) + ((loopy (&seq &optional a b c . d)) + (list a b c d)))))) + +(loopy-def-pcase-test3 pcase-tests-loopy-&rest-sub-seq-1 + :var (a b c) + :result (list 1 2 3) + :tests [( :val (list 1 2 3) + :tests [(:name list :pat (a &rest (b c))) + (:name seq-list-as-list-1 :pat (&seq a &rest (b c))) + (:name seq-list-as-list-2 :pat (&seq a &rest (&seq b c))) + (:name seq-list-as-list-3 :pat (&seq a &rest [&seq b c])) + (:name seq-list-as-vector-1 :pat [&seq a &rest (b c)]) + (:name seq-list-as-vector-2 :pat [&seq a &rest (&seq b c)]) + (:name seq-list-as-vector-3 :pat [&seq a &rest [&seq b c]])]) + ( :val (vector 1 2 3) + :tests [(:name vector :pat [a &rest [b c]]) + (:name seq-vector-as-vector-1 :pat [&seq a &rest [b c]]) + (:name seq-vector-as-vector-2 :pat [&seq a &rest [&seq b c]]) + (:name seq-vector-as-vector-3 :pat [&seq a &rest (&seq b c)]) + (:name seq-vector-as-list-1 :pat (&seq a &rest [b c])) + (:name seq-vector-as-list-2 :pat (&seq a &rest [&seq b c])) + (:name seq-vector-as-list-3 :pat (&seq a &rest (&seq b c)))])]) + +(loopy-def-pcase-test3 pcase-tests-loopy-&rest-sub-seq-2 + :var (a b c) + :result (list 1 2 3) + :tests [( :val (list 1 2 3) + :tests [(:name list :pat (a &body (b c))) + (:name seq-list-as-list-1 :pat (&seq a &body (b c))) + (:name seq-list-as-list-2 :pat (&seq a &body (&seq b c))) + (:name seq-list-as-list-3 :pat (&seq a &body [&seq b c])) + (:name seq-list-as-vector-1 :pat [&seq a &body (b c)]) + (:name seq-list-as-vector-2 :pat [&seq a &body (&seq b c)]) + (:name seq-list-as-vector-3 :pat [&seq a &body [&seq b c]])]) + ( :val (vector 1 2 3) + :tests [(:name vector :pat [a &body [b c]]) + (:name seq-vector-as-vector-1 :pat [&seq a &body [b c]]) + (:name seq-vector-as-vector-2 :pat [&seq a &body [&seq b c]]) + (:name seq-vector-as-vector-3 :pat [&seq a &body (&seq b c)]) + (:name seq-vector-as-list-1 :pat (&seq a &body [b c])) + (:name seq-vector-as-list-2 :pat (&seq a &body [&seq b c])) + (:name seq-vector-as-list-3 :pat (&seq a &body (&seq b c)))])]) + +(loopy-def-pcase-test pcase-tests-loopy-&rest-sub-seq-3 + :result (list 1 2 3) + :val (list 1 2 3) + :var (a b c) + :pat (a . (b c)) + :vector nil + :seq-vector nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-permissive-1 + :doc "`&map' should not require a construct like `&allow-other-keys'." + :result (list 1 2) + :val (list 'a 1 'b 2 'c 3) + :var (a b) + :pat (&map a b) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-permissive-2 + :doc "`&map' should not require a construct like `&allow-other-keys'." + :result (list 1 2) + :val (list :a 1 :b 2 :c 3) + :var (a b) + :pat (&map (:a a) (:b b)) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-not-first-1 + :doc "The map should be after positional values and equal to `&rest'." + :result (list 1 2 3 11 22) + :val (list 1 2 3 'k1 11 'k2 22) + :var (a b c k1 k2) + :pat (a b c &map k1 k2) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-not-first-2 + :doc "The map should be after positional values and equal to `&rest'." + :result (list 1 2 3 (list :k1 11 :k2 22) 11 22) + :val (list 1 2 3 :k1 11 :k2 22) + :var (a b c r1 k1 k2) + :pat (a b c &rest r1 &map (:k1 k1) (:k2 k2)) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-not-first-3 + :doc "The map should be after positional values and equal to `&rest'." + :result (list 0 1 2 [10 11 12] 10 11) + :val [0 1 2 10 11 12] + :var (a b c r1 k0 k1) + :pat (a b c &rest r1 &map (0 k0) (1 k1)) + :list nil + :convert nil) + +;; TODO: HERE!!!!!!!!!!!!! start with `pcase-tests-loopy-&map-full-form' + +(loopy-def-pcase-test pcase-tests-loopy-&map-full-form-1 + :result (list 1 2) + :val (list 'a 1 'b 2) + :var (a b) + :pat (&map a ('b b 13)) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-full-form-2 + :result (list 1 2) + :val (list 'a 1 'b 2) + :var (a b) + :pat (&map a ['b b 13]) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-full-form-3 + :result (list 1 13) + :val (list 'a 1) + :var (a b) + :pat (&map a ('b b 13)) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-full-form-4 + :result (list 1 13) + :val (list 'a 1) + :var (a b) + :pat (&map a ['b b 13]) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-full-form-5 + :result (list 1 13 nil) + :val (list 'a 1) + :var (a b b-supplied) + :pat (&map a ('b b 13 b-supplied)) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-full-form-6 + :result (list 1 2 t) + :val (list 'a 1 'b 2) + :var (a b b-supplied) + :pat (&map a ('b b 13 b-supplied)) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-full-form-7 + :result (list 1 2 t) + :val (list :a 1 :b 2) + :var (a b b-supplied) + :pat (&map (:a a) (:b b 13 b-supplied)) + :vector nil + :convert nil) + +(let ((key :bat)) + (loopy-def-pcase-test pcase-tests-loopy-&map-full-form-8 + :result (list 1 2 t) + :val (list :a 1 :bat 2) + :var (a b b-supplied) + :pat (&map (:a a) (key b 13 b-supplied)) + :vector nil + :convert nil)) + +(loopy-def-pcase-test pcase-tests-loopy-&map-sub-seq-1 + :result '(1 2 (:c 77 :e should-ignore) nil 77 t 99 nil) + :val '(:ab (1 2)) + :var (a b cd cd-supp c c-supp d d-supp) + :pat (&map + (:ab (a b)) + (:cd ( &whole cd + &map + (:c c 88 c-supp) + (:d d 99 d-supp)) + (list :c 77 :e 'should-ignore) + cd-supp)) + :vector nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&map-sub-seq-2 + :result '(1 2 (:c 77 :e should-ignore) nil 77 t 99 nil) + :val (vector (list 1 2)) + :var (a b cd cd-supp c c-supp d d-supp) + :pat [&map + (0 (a b)) + (1 ( &whole cd + &map + (:c c 88 c-supp) + (:d d 99 d-supp)) + (list :c 77 :e 'should-ignore) + cd-supp)] + :list nil + :convert nil) + +(loopy-def-pcase-test pcase-tests-loopy-&aux-1 + :result (list 1 2 nil nil) + :val nil + :var (a b c d) + :pat (&aux (a 1) (b 2) (c) d)) + +(loopy-def-pcase-test pcase-tests-loopy-&aux-2 + :result (list 0 1 2 nil nil) + :val (list 0) + :var (z0 a b c d) + :pat (z0 &aux [a 1] [b 2] [c] d)) + +(loopy-def-pcase-test pcase-tests-loopy-&aux-sub-seq-1 + :result (list 1 2) + :val nil + :var (a b) + :pat (&aux ((a b) (list 1 2)))) + +(loopy-def-pcase-test pcase-tests-loopy-&aux-sub-seq-2 + :result (list 1 2) + :val nil + :var (a b) + :pat (&aux ([a b] (vector 1 2)))) + +(loopy-def-pcase-test pcase-tests-loopy-&aux-sub-seq-3 + :result (list 1 2) + :val nil + :var (a b) + :pat (&aux ([&seq a b] (list 1 2)))) + +(loopy-def-pcase-test pcase-tests-loopy-&aux-sub-seq-4 + :result (list 1 2) + :val nil + :var (a b) + :pat (&aux ((&seq a b) (vector 1 2)))) + +(ert-deftest pcase-tests-loopy-&whole-should-error () + "`&whole' must come first if given, and must be followed by a patter." + (should-error (loopy--pcase-exhaustive-wrapper (a b c) + (list 1 2 3) + ((loopy (&whole)) + (list a b c))) + :type 'loopy-&whole-missing) + + (should-error (loopy--pcase-exhaustive-wrapper (a b c) + (list 1 2 3) + ((loopy (&whole &rest)) + (list a b c))) + :type 'loopy-&whole-missing) + + (should-error (loopy--pcase-exhaustive-wrapper (a b c) + (list 1 2 3) + ((loopy (&whole _ &rest)) + (list a b c))) + :type 'loopy-&whole-missing) + + (should-error (loopy--pcase-exhaustive-wrapper (a b c) + (list 1 2 3) + ((loopy (a b &whole c)) + (list a b c))) + :type 'loopy-&whole-bad-position) + + (should-error (loopy--pcase-exhaustive-wrapper (a b c) + (list 1 2 3) + ((loopy (&rest a &whole c)) + (list a b c))) + :type 'loopy-&whole-bad-position) + + (should-error (loopy--pcase-exhaustive-wrapper (a b c) + (list 1 2 3) + ((loopy (&key a &whole c)) + (list a b c))) + :type 'loopy-&whole-bad-position) + + (should-error (loopy--pcase-exhaustive-wrapper (a b c) + (list 1 2 3) + ((loopy (&aux (a 1) &whole c)) + (list a b c))) + :type 'loopy-&whole-bad-position) + + (should-error (loopy--pcase-exhaustive-wrapper (a b c) + (list 1 2 3) + ((loopy (&optional (a 1) &whole c)) + (list a b c))) + :type 'loopy-&whole-bad-position) + + (should-error (loopy--pcase-exhaustive-wrapper (whole1 whole2) + (list 1 2 3) + ((loopy (&whole whole1 &whole whole2)) + (list whole1 whole2))) + :type 'loopy-&whole-bad-position)) + + (ert-deftest pcase-tests-loopy-&optional-should-error () "`&optional' cannot be used after `&optional', `&rest', `&key', and `&aux'." (should-error (equal (list 1 2 3) @@ -763,201 +1881,6 @@ Prior to Emacs 28, `pcase' didn't guarantee binding all variables. (list a b c))) :type 'loopy-&optional-bad-position)) -(ert-deftest pcase-tests-loopy-&optional () - (should (equal (list 1 2 3) - (loopy--pcase-exhaustive-wrapper (a b c) - (list 1 2 3) - ((loopy (a b &optional c)) - (list a b c))))) - - (should (equal (list 1 2 nil) - (loopy--pcase-exhaustive-wrapper (a b c) - (list 1 2) - ((loopy (a b &optional c)) - (list a b c))))) - - (should (equal (list 1 2 13) - (loopy--pcase-exhaustive-wrapper (a b c) - (list 1 2) - ((loopy (a b &optional (c 13))) - (list a b c))))) - - (should (equal (list 1 2 13) - (loopy--pcase-exhaustive-wrapper (a b c) - (list 1 2) - ((loopy (a b &optional [c 13])) - (list a b c))))) - - (should (equal (list 1 2 13 nil) - (loopy--pcase-exhaustive-wrapper (a b c c-supplied) - (list 1 2) - ((loopy (a b &optional [c 13 c-supplied])) - (list a b c c-supplied))))) - - (should (equal (list 1 2 3 t) - (loopy--pcase-exhaustive-wrapper (a b c c-supplied) - (list 1 2 3) - ((loopy (a b &optional [c 13 c-supplied])) - (list a b c c-supplied)))))) - -(ert-deftest pcase-tests-loopy-&optional-ignored () - (should (equal (list 1 2 nil) - (loopy--pcase-exhaustive-wrapper (a b d) - (list 1 2) - ((loopy (a b &optional _ d)) - (list a b d))))) - - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - (list 1 2) - ((loopy (a b &optional _ _)) - (list a b))))) - - (should (equal (list 1 2 13 nil) - (loopy--pcase-exhaustive-wrapper (a b k1 k2) - (list 1 2) - ((loopy (a b &optional _ _ &key [k1 13] k2)) - (list a b k1 k2))))) - - (should (equal (list 1 2 nil 14 nil) - (loopy--pcase-exhaustive-wrapper (a b e k1 k2) - (list 1 2) - ((loopy (a b &optional _ _ &rest e &key [k1 14] k2)) - (list a b e k1 k2))))) - - (should (equal (list 1 2 nil 14 nil) - (loopy--pcase-exhaustive-wrapper (a b e k1 k2) - (list 1 2) - ((loopy (a b &optional _ _ &rest e &map [:k1 k1 14] (:k2 k2))) - (list a b e k1 k2))))) - - (should (equal (list 1 2 nil) - (loopy--pcase-exhaustive-wrapper (a b d) - (vector 1 2) - ((loopy [a b &optional _ d]) - (list a b d))))) - - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - (vector 1 2) - ((loopy [a b &optional _ _]) - (list a b))))) - - ;; FIXME: This test fails on Emacs 27 because the tests don't install the - ;; correct version of Map.el. - (when (> emacs-major-version 27) - (should (equal (list 1 2 [] 14 nil) - (loopy--pcase-exhaustive-wrapper (a b e k1 k2) - (vector 1 2) - ((loopy [a b &optional _ _ &rest e &map [:k1 k1 14] (:k2 k2)]) - (list a b e k1 k2))))))) - -(ert-deftest pcase-tests-loopy-&optional-sub-seq () - "Test using sub-seq in `loopy' pattern. -sub-seq must be contained within a sub-list, since a sub-list -also provides a default value." - (should (equal (list 1 2 3 4) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2 (list 3 4)) - ((loopy (a b &optional ((c d)))) - (list a b c d))))) - - (should (equal (list 1 2 3 4) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2 (list 3 4)) - ((loopy (a b &optional [(c d)])) - (list a b c d))))) - - (should (equal (list 1 2 nil nil) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2) - ((loopy (a b &optional ((c d)))) - (list a b c d))))) - - (should (equal (list 1 2 nil nil) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2) - ((loopy (a b &optional [(c d)])) - (list a b c d))))) - - (should (equal (list 1 2 13 14) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2) - ((loopy (a b &optional ((c d) (list 13 14)))) - (list a b c d))))) - - (should (equal (list 1 2 13 14) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2) - ((loopy (a b &optional [(c d) (list 13 14)])) - (list a b c d))))) - - (should (equal (list 1 2 13 14) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2) - ((loopy ( a b - &optional ((c &optional (d 14)) - (list 13)))) - (list a b c d))))) - - (should (equal (list 1 2 13 14) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2) - ((loopy ( a b - &optional ((c &optional [d 14]) - (list 13)))) - (list a b c d))))) - - (should (equal (list 1 2 13 14) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2) - ((loopy ( a b - &optional [(c &optional (d 14)) - (list 13)])) - (list a b c d))))) - - (should (equal (list 1 2 13 14) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2) - ((loopy ( a b - &optional [(c &optional [d 14]) - (list 13)])) - (list a b c d))))) - - (should (equal (list 1 2 13 14 nil) - (loopy--pcase-exhaustive-wrapper (a b c d cd-supplied) - (list 1 2) - ((loopy (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) - (loopy--pcase-exhaustive-wrapper (a b c d cd-supplied) - (list 1 2) - ((loopy (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) - (loopy--pcase-exhaustive-wrapper (a b c d cd-supplied c-sub-sup d-sub-sup) - (list 1 2) - ((loopy ( a b - &optional - ((&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))))) - - (should (equal (list 1 2 13 14 nil t nil) - (loopy--pcase-exhaustive-wrapper (a b c d cd-supplied c-sub-sup d-sub-sup) - (list 1 2) - ((loopy ( a b - &optional - [(&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-loopy-&rest-should-error () "`&rest' (`&body', `.') cannot be used after `&rest', `&body', `&key',and `&aux'." (should-error (equal (list 1 2 3) @@ -1005,122 +1928,6 @@ also provides a default value." (list a b c))) :type 'loopy-&rest-bad-position)) -(ert-deftest pcase-tests-loopy-&rest-ignored () - - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - [1 2 3] - ((loopy [a b &rest _]) - (list a b))))) - - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - '(1 2 3) - ((loopy (a b &rest _)) - (list a b))))) - - (should (equal (list 1 2 3 11 12) - (loopy--pcase-exhaustive-wrapper (a b c k1 k2) - '(1 2 3 :k1 11 :k2 12) - ((loopy (a b c &rest _ &key k1 k2)) - (list a b c k1 k2))))) - - (should (equal (list 1 2 3 11 12) - (loopy--pcase-exhaustive-wrapper (a b c k1 k2) - '(1 2 3 :k1 11 :k2 12) - ((loopy (a b c &rest _ &map (:k1 k1) (:k2 k2))) - (list a b c k1 k2)))))) - -(ert-deftest pcase-tests-loopy-&rest-nonlist-cdr () - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - (cons 1 2) - ((loopy (a &rest b)) - (list a b))))) - - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - (cons 1 2) - ((loopy (a &body b)) - (list a b))))) - - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - (cons 1 2) - ((loopy (a . b)) - (list a b)))))) - -(ert-deftest pcase-tests-loopy-&rest-with-&whole () - (should (equal (list (cons 1 2) 1 2) - (loopy--pcase-exhaustive-wrapper (whole a b) - (cons 1 2) - ((loopy (&whole whole a &rest b)) - (list whole a b))))) - - (should (equal (list (cons 1 2) 1 2) - (loopy--pcase-exhaustive-wrapper (whole a b) - (cons 1 2) - ((loopy (&whole whole a &body b)) - (list whole a b))))) - - (should (equal (list (cons 1 2) 1 2) - (loopy--pcase-exhaustive-wrapper (whole a b) - (cons 1 2) - ((loopy (&whole whole a . b)) - (list whole a b)))))) - -(ert-deftest pcase-tests-loopy-&rest-only () - "Using only `&rest' should work like `&whole'." - (should (equal (list (list 1 2)) - (loopy--pcase-exhaustive-wrapper (a) - (list 1 2) - ((loopy (&rest a)) - (list a))))) - - (should (equal (list (cons 1 2)) - (loopy--pcase-exhaustive-wrapper (a) - (cons 1 2) - ((loopy (&body a)) - (list a)))))) - -(ert-deftest pcase-tests-loopy-&rest-after-&optional () - (should (equal (list 1 2 3 (list 4 5)) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2 3 4 5) - ((loopy (&optional a b c &rest d)) - (list a b c d))))) - - (should (equal (list 1 2 3 (list 4 5)) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2 3 4 5) - ((loopy (&optional a b c &body d)) - (list a b c d))))) - - (should (equal (list 1 2 3 (list 4 5)) - (loopy--pcase-exhaustive-wrapper (a b c d) - (list 1 2 3 4 5) - ((loopy (&optional a b c . d)) - (list a b c d)))))) - -(ert-deftest pcase-tests-loopy-&rest-sub-seq () - (should (equal (list 1 2 3) - (loopy--pcase-exhaustive-wrapper (a b c) - (list 1 2 3) - ((loopy (a &rest (b c))) - (list a b c))))) - - (should (equal (list 1 2 3) - (loopy--pcase-exhaustive-wrapper (a b c) - (list 1 2 3) - ((loopy (a . (b c))) - (list a b c))))) - - (should (equal (list 1 2 3) - (loopy--pcase-exhaustive-wrapper (a b c) - (list 1 2 3) - ((loopy (a &body (b c))) - (list a b c)))))) - (ert-deftest pcase-tests-loopy-&key-should-error () "`&key' cannot be used after `&key', `&allow-other-keys', and `&aux'." (should-error (loopy--pcase-exhaustive-wrapper (a b) @@ -1189,20 +1996,6 @@ also provides a default value." ((loopy (&key a b)) (list a b)))))) -(ert-deftest pcase-tests-loopy-&map-permissive () - "`&map' should not require a construct like `&allow-other-keys'." - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - (list 'a 1 'b 2 'c 3) - ((loopy (&map a b)) - (list a b))))) - - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - (list :a 1 :b 2 :c 3) - ((loopy (&map (:a a) (:b b))) - (list a b)))))) - (ert-deftest pcase-tests-loopy-&key-not-first () "The plist should be after positional values and equal to `&rest'." (should (equal (list 1 2 3 11 22) @@ -1217,20 +2010,6 @@ also provides a default value." ((loopy (a b c &rest r1 &key k1 k2)) (list a b c r1 k1 k2)))))) -(ert-deftest pcase-tests-loopy-&map-not-first () - "The map should be after positional values and equal to `&rest'." - (should (equal (list 1 2 3 11 22) - (loopy--pcase-exhaustive-wrapper (a b c k1 k2) - (list 1 2 3 'k1 11 'k2 22) - ((loopy (a b c &map k1 k2)) - (list a b c k1 k2))))) - - (should (equal (list 1 2 3 (list :k1 11 :k2 22) 11 22) - (loopy--pcase-exhaustive-wrapper (a b c r1 k1 k2) - (list 1 2 3 :k1 11 :k2 22) - ((loopy (a b c &rest r1 &map (:k1 k1) (:k2 k2))) - (list a b c r1 k1 k2)))))) - (ert-deftest pcase-tests-loopy-&key-full-form () (should (equal (list 1 2) (loopy--pcase-exhaustive-wrapper (a b) @@ -1293,44 +2072,6 @@ also provides a default value." ((loopy (&key a ((key b) 13 b-supplied))) (list a b b-supplied))))))) -(ert-deftest pcase-tests-loopy-&map-full-form () - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - (list 'a 1 'b 2) - ((loopy (&map a ('b b 13))) - (list a b))))) - - (should (equal (list 1 13) - (loopy--pcase-exhaustive-wrapper (a b) - (list 'a 1) - ((loopy (&map a ('b b 13))) - (list a b))))) - - (should (equal (list 1 13 nil) - (loopy--pcase-exhaustive-wrapper (a b b-supplied) - (list 'a 1) - ((loopy (&map a ('b b 13 b-supplied))) - (list a b b-supplied))))) - - (should (equal (list 1 2 t) - (loopy--pcase-exhaustive-wrapper (a b b-supplied) - (list 'a 1 'b 2) - ((loopy (&map a ('b b 13 b-supplied))) - (list a b b-supplied))))) - - (should (equal (list 1 2 t) - (loopy--pcase-exhaustive-wrapper (a b b-supplied) - (list :a 1 :bat 2) - ((loopy (&map (:a a) (:bat b 13 b-supplied))) - (list a b b-supplied))))) - - (should (equal (list 1 2 t) - (let ((key :bat)) - (loopy--pcase-exhaustive-wrapper (a b b-supplied) - (list :a 1 :bat 2) - ((loopy (&map (:a a) (key b 13 b-supplied))) - (list a b b-supplied))))))) - (ert-deftest pcase-tests-loopy-&key-sub-seq () (should (equal '(1 2 (:c 77 :e should-ignore) nil 77 t 99 nil) (loopy--pcase-exhaustive-wrapper @@ -1363,35 +2104,20 @@ also provides a default value." cd-supp))) (list a b cd cd-supp c c-supp d d-supp))))) - (should (equal nil - (loopy--pcase-exhaustive-wrapper - (a b cd cd-supp c c-supp d d-supp) - '(:ab (1 2)) - ((loopy (&key - ((:ab (a b))) - ((:cd ( &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)) - (_ nil))))) - -(ert-deftest pcase-tests-loopy-&map-sub-seq () - (should (equal '(1 2 (:c 77 :e should-ignore) nil 77 t 99 nil) - (loopy--pcase-exhaustive-wrapper - (a b cd cd-supp c c-supp d d-supp) - '(:ab (1 2)) - ((loopy (&map - (:ab (a b)) - (:cd ( &whole cd - &map - (:c c 88 c-supp) - (:d d 99 d-supp)) - (list :c 77 :e 'should-ignore) - cd-supp))) - (list a b cd cd-supp c c-supp d d-supp)))))) + (should-error + (loopy--pcase-exhaustive-wrapper + (a b cd cd-supp c c-supp d d-supp) + '(:ab (1 2)) + ((loopy (&key + ((:ab (a b))) + ((:cd ( &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))) + :type 'loopy-pcase-no-match)) (ert-deftest pcase-tests-loopy-&aux-should-error () "`&aux' cannot be used after `&aux'." @@ -1401,26 +2127,6 @@ also provides a default value." (list a b))) :type 'loopy-&aux-bad-position)) -(ert-deftest pcase-tests-loopy-&aux () - (should (equal (list 1 2 nil nil) - (loopy--pcase-exhaustive-wrapper (a b c d) - nil - ((loopy (&aux (a 1) (b 2) (c) d)) - (list a b c d))))) - - (should (equal (list 0 1 2 nil nil) - (loopy--pcase-exhaustive-wrapper (z0 a b c d) - (list 0) - ((loopy (z0 &aux (a 1) (b 2) (c) d)) - (list z0 a b c d)))))) - -(ert-deftest pcase-tests-loopy-&aux-sub-seq () - (should (equal (list 1 2) - (loopy--pcase-exhaustive-wrapper (a b) - nil - ((loopy (&aux ((a b) (list 1 2)))) - (list a b)))))) - (ert-deftest pcase-tests-loopy-all () (should (equal '(1 2 3 4 5 (:k1 111 :k2 222) 111 222 111 222 333 444) (loopy--pcase-exhaustive-wrapper diff --git a/tests/tests.el b/tests/tests.el index f6c6d466f..dbc1c9977 100644 --- a/tests/tests.el +++ b/tests/tests.el @@ -13,9 +13,14 @@ (require 'cl-lib) (require 'package) -(unless (featurep 'compat) - (dolist (dir (cl-remove-if-not #'file-directory-p (directory-files (expand-file-name package-user-dir) t "compat"))) - (push dir load-path))) +(dolist (feature '(compat stream)) + (unless (featurep feature) + (dolist (dir (seq-filter #'file-directory-p + (directory-files + (expand-file-name package-user-dir) + t + (symbol-name feature)))) + (push dir load-path)))) (require 'subr-x) (require 'package) @@ -2838,6 +2843,167 @@ Using numbers directly will use less variables and more efficient code." :iter-bare ((seq-ref . sequencing-ref) (do . ignore))) +;;;;; Stream +(loopy-deftest stream-names + :result '(0 1 2) + :body ((_cmd i (stream [0 1 2])) + (collect i)) + :repeat _cmd + :loopy ((_cmd . (stream streaming)) + (collect . collect)) + :iter-keyword ((_cmd . (stream streaming)) + (collect . collect)) + :iter-bare ((_cmd . (streaming)) + (collect . collecting))) + +(loopy-deftest stream-destr + :result '((0 1 2) + (3 4 5)) + :body ((stream (i j k) (loopy-test-escape (stream [(0 1 2) (3 4 5)]))) + (collect (list i j k))) + :loopy t + :iter-keyword (stream collect) + :iter-bare ((stream . streaming) + (collect . collecting))) + +(loopy-deftest stream-:by-const + :result '(0 2 4 6) + :body ((stream i (loopy-test-escape (stream [0 1 2 3 4 5 6])) :by 2) + (collect i)) + :loopy t + :iter-keyword (stream collect) + :iter-bare ((stream . streaming) + (collect . collecting))) + +(loopy-deftest stream-:by-only-once + :doc "Keywords like `length' should only be evaluated once." + :result '(0 2 4 6) + :body ((with (times 0)) + (stream i (loopy-test-escape (stream [0 1 2 3 4 5 6])) + :by (progn + (cl-assert (= times 0)) + (cl-incf times) + 2)) + (collect i)) + :loopy t + :iter-keyword (stream collect set) + :iter-bare ((set . setting) + (stream . streaming) + (collect . collecting))) + +;;;;; Substream + +(loopy-deftest substream-no-&seq-error + :doc "Although implemented as lists, substream can only be destructured by `&seq'." + :error loopy-substream-not-&seq + :body ((substream (i) (loopy-test-escape (stream (vector 0 1 2)))) + (collect i)) + :loopy t + :iter-keyword (substream collect) + :iter-bare ((substream . substreaming) + (collect . collecting))) + +(loopy-deftest substream-no-&seq-no-error + :doc "We shouldn't signal an error if we're not using the default system." + :result '(0 1 2) + :wrap ((x . `(progn (require 'loopy-seq) ,x))) + :body ((flag seq) + (substream (i) (loopy-test-escape (stream (vector 0 1 2)))) + (collect i)) + :loopy t + :iter-keyword (substream collect) + :iter-bare ((substream . substreaming) + (collect . collecting))) + +(loopy-deftest substream-names + :result '(0 1 2) + :body ((_cmd i (loopy-test-escape (stream [0 1 2]))) + (collect (stream-first i))) + :repeat _cmd + :loopy ((_cmd . (substream substreaming)) + (collect . collect)) + :iter-keyword ((_cmd . (substream substreaming)) + (collect . collect)) + :iter-bare ((_cmd . (substreaming)) + (collect . collecting))) + +(loopy-deftest substream-destr + :result '((0 1 2) + (1 2 nil) + (2 nil nil)) + :body ((substream (&seq i j k) (loopy-test-escape (stream [0 1 2]))) + (collect (list i j k))) + :loopy t + :iter-keyword (substream collect) + :iter-bare ((substream . substreaming) + (collect . collecting))) + +(loopy-deftest substream-:length-const + :result '((0 1 2) (1 2 3) (2 3 4) (3 4 5) (4 5 6) (5 6) (6)) + :body ((substream i (loopy-test-escape (stream [0 1 2 3 4 5 6])) :length 3) + (set res nil) + (do (seq-do (lambda (x) (push x res)) + i)) + (collect (reverse res))) + :loopy t + :iter-keyword (substream collect set do) + :iter-bare ((set . setting) + (substream . substreaming) + (collect . collecting) + (do . progn))) + +(loopy-deftest substream-:length-only-once + :doc "Keywords like `length' should only be evaluated once." + :result '((0 1 2) (1 2 3) (2 3 4) (3 4 5) (4 5 6) (5 6) (6)) + :body ((with (times 0)) + (substream i (loopy-test-escape (stream [0 1 2 3 4 5 6])) :length (progn + (cl-assert (= times 0)) + (cl-incf times) + 3)) + (set res nil) + (do (seq-do (lambda (x) (push x res)) + i)) + (collect (reverse res))) + :loopy t + :iter-keyword (substream collect set do) + :iter-bare ((set . setting) + (substream . substreaming) + (collect . collecting) + (do . progn))) + +(loopy-deftest substream-:by-const + :result '((0 1 2 3 4 5 6) (2 3 4 5 6) (4 5 6) (6)) + :body ((substream i (loopy-test-escape (stream [0 1 2 3 4 5 6])) :by 2) + (set res nil) + (do (seq-do (lambda (x) (push x res)) + i)) + (collect (reverse res))) + :loopy t + :iter-keyword (substream collect set do) + :iter-bare ((set . setting) + (substream . substreaming) + (collect . collecting) + (do . progn))) + +(loopy-deftest substream-:by-only-once + :doc "Keywords like `length' should only be evaluated once." + :result '((0 1 2 3 4 5 6) (2 3 4 5 6) (4 5 6) (6)) + :body ((with (times 0)) + (substream i (loopy-test-escape (stream [0 1 2 3 4 5 6])) :by (progn + (cl-assert (= times 0)) + (cl-incf times) + 2)) + (set res nil) + (do (seq-do (lambda (x) (push x res)) + i)) + (collect (reverse res))) + :loopy t + :iter-keyword (substream collect set do) + :iter-bare ((set . setting) + (substream . substreaming) + (collect . collecting) + (do . progn))) + ;;;; Accumulation Commands ;;;;; Final updates