From 7ea85f928457b1d4ec029b5875d7dafce6da3b5a Mon Sep 17 00:00:00 2001 From: okamsn Date: Thu, 19 Oct 2023 21:13:35 -0400 Subject: [PATCH] Improve keyword arguments `test` and `key`. - Document the argument order of `test` as the first argument being the value from the sequence and the second argument being the tested item. This is the same order as used by `seq-contains-p` and the opposite of `cl-member`. - Add `loopy--member-p`, used for tests for `adjoin`, `union`, and `nunion`. This function can be optimized during byte compilation via `loopy--member-p-comp` to become `member`, `memq`, or `memql` when possible, as done with `cl-member`. - Simplify `loopy--plist-bind` into a wrapper around `cl-destructuring-bind`. - Add `loopy--instr-let2*`, with works like `macroexp-let2*` except that it will also append variable-instructions to the result of the body as needed. This will allow us to stop manually checking in each command whether we need to create a variable to hold a value. Now, we create the variable is `macroexp-const-p` believes that the value would not be constant. - Do not remove `key`. The use of a separate argument allows us to optimize the transform function by only calling it once on the tested item during the execution of each command. It is decided that re-creating this behavior with `set` and an ignored argument in the test function is too awkward. - Remove mention of `init` keyword argument, which should have been deleted already. - Add examples for the common accumulation keyword arguments. - Update the CHANGELOG and correct some links. - Update the README. See also issues #176, #170, and this PR. --- CHANGELOG.md | 19 ++- README.org | 5 + doc/loopy-doc.org | 91 ++++++++++-- doc/loopy.texi | 106 +++++++++++--- loopy-commands.el | 330 +++++++++++++++++++++++--------------------- loopy-misc.el | 130 ++++++++++++----- tests/misc-tests.el | 13 ++ 7 files changed, 466 insertions(+), 228 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2929b0e3..c6d1c79f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,7 +22,7 @@ This document describes the user-facing changes to Loopy. (reduce i #'*)) ``` -- Fix `find` when `:on-failure` is nil ([#170]). Previously, `nil` was +- Fix `find` when `:on-failure` is nil ([#171]). Previously, `nil` was interpreted as not passing `:on-failure`. ```emacs-lisp @@ -34,7 +34,7 @@ This document describes the user-facing changes to Loopy. (finally-return val)) ``` -- Fix `find` when `EXPR` is nil and `:on-failure` is given ([#170]). +- Fix `find` when `EXPR` is nil and `:on-failure` is given ([#171]). Previously, after the test passed and `VAR` was set to `nil`, that `nil` was interpreted as not passing the test, so that `VAR` then bound to the value passed for `:on-failure`. @@ -79,6 +79,15 @@ This document describes the user-facing changes to Loopy. (list i '(4 5 6))) ``` +- In `adjoin`, `nunion`, and `union`, the `test` and `key` keywords are now + evaluated only once. This is now consistent with passing function values of + other loop commands. See [#170] and [#177]. + +- In accumulation commands using the `test` keyword argument, the argument order + of the two-argument test function is now document as `(SEQUENCE-ITEM, + TESTED-ITEM)`, similar to `seq-contains-p`. The argument order was previously + undocumented and not guaranteed. See [#170] and [#177]. + #### Removals - The deprecated flag `split` was removed ([#165], [#131], [#124]). Instead, @@ -200,9 +209,11 @@ This document describes the user-facing changes to Loopy. [#163]: https://github.com/okamsn/loopy/pull/163 [#164]: https://github.com/okamsn/loopy/pull/164 [#165]: https://github.com/okamsn/loopy/pull/165 -[#170]: https://github.com/okamsn/loopy/pull/170 -[#171]: https://github.com/okamsn/loopy/pull/172 +[#170]: https://github.com/okamsn/loopy/issues/170 +[#171]: https://github.com/okamsn/loopy/pull/171 +[#172]: https://github.com/okamsn/loopy/pull/172 [#173]: https://github.com/okamsn/loopy/pull/173 +[#177]: https://github.com/okamsn/loopy/pull/177 ## 0.11.2 diff --git a/README.org b/README.org index 23f9cf9e..cd5f04fd 100644 --- a/README.org +++ b/README.org @@ -58,6 +58,11 @@ please let me know. flexible and explicit than the non-keyword arguments. - Fixed a problem with macro expansion in some cases for sub-macros that created a new macro environment (e.g., ~cl-flet~). + - In =adjoin=, =nunion=, and =union=, only evaluate =:test= and =:key= + arguments once. + - Change the argument order of =test= to be (1) the sequence element then (2) + the tested value, like in ~seq-contains-p~ and _unlike_ in ~cl-member~, and + explicitly state this order in the documentation. - See the [[https://github.com/okamsn/loopy/blob/master/CHANGELOG.md][change log]] for less recent changes. # This auto-generated by toc-org. diff --git a/doc/loopy-doc.org b/doc/loopy-doc.org index 8830f59d..a662d17f 100644 --- a/doc/loopy-doc.org +++ b/doc/loopy-doc.org @@ -2334,8 +2334,8 @@ You will notice that each accumulation command has an alias of the command name in the present participle form (the "-ing" form). For example, instead of "minimize", you can use "minimizing". Instead of "sum" and "append", you can use "summing" and "appending". This is similar to the behavior of ~cl-loop~, -and helps to avoid name collisions when using the ~loopy-iter~ macro ([[#loopy-iter][The -~loopy-iter~ Macro]]). +and helps to avoid name collisions when using the ~loopy-iter~ macro +([[#loopy-iter][The ~loopy-iter~ Macro]]). #+cindex: accumulation keyword arguments Some accumulation commands have optional keyword parameters, which are listed @@ -2347,6 +2347,16 @@ all described below. (equivalent to =start=). If ungiven, defaults to =end=. These positions need not be quoted. + #+begin_src emacs-lisp + ;; => (1 2 3) + (loopy (list i '(1 2 3)) + (collect i :at end)) + + ;; => (3 2 1) + (loopy (list i '(1 2 3)) + (collect i :at start)) + #+end_src + #+cindex: accumulation keyword into - =into= :: An alternative way to specify the variable into which to accumulate values. One would normally just give =VAR= as the first @@ -2356,18 +2366,73 @@ all described below. As all accumulation commands support this keyword, it is not listed in any command definition. + #+begin_src emacs-lisp + ;; => (1 2 3) + (loopy (list i '(1 2 3)) + (collect my-collection i) + (finally-return my-collection)) + + ;; => (1 2 3) + (loopy (list i '(1 2 3)) + (collect i :into my-collection) + (finally-return my-collection)) + #+end_src + #+cindex: accumulation keyword test - =test= :: A function of two arguments, usually used to test for equality. - Most tests default to ~equal~, like in other Emacs Lisp libraries. This is - different from =cl-lib=, which mimics Common Lisp and prefers using ~eql~. + This function is normally used to test if a value is already present in the + accumulating sequence. If so, the function should return a non-nil value. + + #+attr_texinfo: :tag Note + #+begin_quote + This argument is similar to the =:test= argument used by =cl-lib=, but is + closer to the optional =testfn= argument used by =seq= (for example, in + ~seq-contains-p~). This are two important differences: + 1. Tests default to ~equal~, like in other Emacs Lisp libraries, not ~eql~. + 2. The first argument is the existing value or sequence and the second + argument is the tested value. This is the /opposite/ of the order used by + ~cl-member~ and ~memq~. + #+end_quote + + #+begin_src emacs-lisp + ;; Only add items to the list whose `car's are not already present + ;; or whose `cdr' is not 3: + ;; + ;; => ((a . 1) (c . 4)) + (loopy (with (test-fn (lambda (seq-val new-val) + (or (equal (cdr new-val) + 3) + (eq (car seq-val) + (car new-val)))))) + (list i '((a . 1) (a . 2) (b . 3) (c . 4))) + (adjoin i :test test-fn)) + #+end_src #+cindex: accumulation keyword key -- =key= :: A function of one argument, used to transform the inputs of - =test=. +- =key= :: A one-argument function that transforms the _both_ tested value and + the value from sequence used by the =test= keyword. + + The keyword =key= is useful to avoid applying a transforming function to the + tested value more than once when searching through a long sequence, as would + be done if it were called explicitly in =test=. + + #+begin_src emacs-lisp + ;; => ((a . 1) (b . 2) (c . 4)) + (loopy (with (test #'car)) + (list i '((a . 1) (b . 2) (a . 3) (c . 4))) + (adjoin i :at end :key #'car)) + + ;; Similary to the above: + ;; + ;; => ((a . 1) (b . 2) (c . 4)) + (loopy (with (test-val)) + (list i '((a . 1) (b . 2) (a . 3) (c . 4))) + (set test-val (car i)) + (adjoin i :test (lambda (seq-val _) + (equal (car seq-val) + test-val)))) + #+end_src -#+cindex: accumulation keyword init -- =init= :: The initial value of =VAR=. For explicitly named variables, one - can use this argument or the =with= special macro argument. The arguments to the =test= and =key= parameters can be quoted functions or variables, just like when using ~cl-union~, ~cl-adjoin~, and so on. ~loopy~ @@ -2617,11 +2682,11 @@ multiplying values together. :END: Sequence accumulation commands are used to join lists (such as =union= and -=append=) and to collect items into lists (such as =collect=). +=append=) and to collect items into lists (such as =collect= and =adjoin=). #+findex: adjoin #+findex: adjoining -- =(adjoin VAR EXPR &key at test)= :: Repeatedly add =EXPR= to =VAR= if it +- =(adjoin VAR EXPR &key at test key)= :: Repeatedly add =EXPR= to =VAR= if it is not already present in the list. This command also has the alias =adjoining=. @@ -2750,7 +2815,7 @@ Sequence accumulation commands are used to join lists (such as =union= and #+findex: nunion #+findex: nunioning -- =(nunion VAR EXPR &key test at)= :: Repeatedly and /destructively/ insert +- =(nunion VAR EXPR &key test at key)= :: Repeatedly and /destructively/ insert into =VAR= the elements of =EXPR= which are not already present in =VAR=. This command also has the alias =nunioning=. @@ -2819,7 +2884,7 @@ Sequence accumulation commands are used to join lists (such as =union= and #+findex: union #+findex: unioning -- =(union VAR EXPR &key test at)= :: Repeatedly insert into =VAR= the +- =(union VAR EXPR &key test at key)= :: Repeatedly insert into =VAR= the elements of the list =EXPR= that are not already present in =VAR=. This command also has the alias =unioning=. diff --git a/doc/loopy.texi b/doc/loopy.texi index b772b4d1..3d0e482d 100644 --- a/doc/loopy.texi +++ b/doc/loopy.texi @@ -705,7 +705,7 @@ You should keep in mind that commands are evaluated in order. This means that attempting something like the below example might not do what you expect, as @samp{i} is assigned a value from the list after collecting @samp{i} into @samp{coll}. -@float Listing,orgd11885b +@float Listing,org9e6a997 @lisp ;; => (nil 1 2) (loopy (collect coll i) @@ -828,7 +828,7 @@ the flag @samp{dash} provided by the package @samp{loopy-dash}. Below are two examples of destructuring in @code{cl-loop} and @code{loopy}. -@float Listing,org27388de +@float Listing,org866b582 @lisp ;; => (1 2 3 4) (cl-loop for (i . j) in '((1 . 2) (3 . 4)) @@ -843,7 +843,7 @@ Below are two examples of destructuring in @code{cl-loop} and @code{loopy}. @caption{Destructuring values in a list.} @end float -@float Listing,org2966e15 +@float Listing,orgedbe07f @lisp ;; => (1 2 3 4) (cl-loop for elem in '((1 . 2) (3 . 4)) @@ -2491,8 +2491,8 @@ You will notice that each accumulation command has an alias of the command name in the present participle form (the ``-ing'' form). For example, instead of ``minimize'', you can use ``minimizing''. Instead of ``sum'' and ``append'', you can use ``summing'' and ``appending''. This is similar to the behavior of @code{cl-loop}, -and helps to avoid name collisions when using the @code{loopy-iter} macro (@ref{The @code{loopy-iter} Macro, , The -@code{loopy-iter} Macro}). +and helps to avoid name collisions when using the @code{loopy-iter} macro +(@ref{The @code{loopy-iter} Macro}). @cindex accumulation keyword arguments Some accumulation commands have optional keyword parameters, which are listed @@ -2505,6 +2505,16 @@ all described below. Where to place a value. One of @samp{end}, @samp{start}, or @samp{beginning} (equivalent to @samp{start}). If ungiven, defaults to @samp{end}. These positions need not be quoted. + +@lisp +;; => (1 2 3) +(loopy (list i '(1 2 3)) + (collect i :at end)) + +;; => (3 2 1) +(loopy (list i '(1 2 3)) + (collect i :at start)) +@end lisp @end table @cindex accumulation keyword into @@ -2517,30 +2527,86 @@ argument for a more @code{cl-loop}-like syntax. As all accumulation commands support this keyword, it is not listed in any command definition. + +@lisp +;; => (1 2 3) +(loopy (list i '(1 2 3)) + (collect my-collection i) + (finally-return my-collection)) + +;; => (1 2 3) +(loopy (list i '(1 2 3)) + (collect i :into my-collection) + (finally-return my-collection)) +@end lisp @end table @cindex accumulation keyword test @table @asis @item @samp{test} A function of two arguments, usually used to test for equality. -Most tests default to @code{equal}, like in other Emacs Lisp libraries. This is -different from @samp{cl-lib}, which mimics Common Lisp and prefers using @code{eql}. +This function is normally used to test if a value is already present in the +accumulating sequence. If so, the function should return a non-nil value. + +@quotation Note +This argument is similar to the @samp{:test} argument used by @samp{cl-lib}, but is +closer to the optional @samp{testfn} argument used by @samp{seq} (for example, in +@code{seq-contains-p}). This are two important differences: +@enumerate +@item +Tests default to @code{equal}, like in other Emacs Lisp libraries, not @code{eql}. +@item +The first argument is the existing value or sequence and the second +argument is the tested value. This is the @emph{opposite} of the order used by +@code{cl-member} and @code{memq}. +@end enumerate + +@end quotation + +@lisp +;; Only add items to the list whose `car's are not already present +;; or whose `cdr' is not 3: +;; +;; => ((a . 1) (c . 4)) +(loopy (with (test-fn (lambda (seq-val new-val) + (or (equal (cdr new-val) + 3) + (eq (car seq-val) + (car new-val)))))) + (list i '((a . 1) (a . 2) (b . 3) (c . 4))) + (adjoin i :test test-fn)) +@end lisp @end table @cindex accumulation keyword key @table @asis @item @samp{key} -A function of one argument, used to transform the inputs of -@samp{test}. -@end table +A one-argument function that transforms the both tested value and +the value from sequence used by the @samp{test} keyword. -@cindex accumulation keyword init -@table @asis -@item @samp{init} -The initial value of @samp{VAR}. For explicitly named variables, one -can use this argument or the @samp{with} special macro argument. +The keyword @samp{key} is useful to avoid applying a transforming function to the +tested value more than once when searching through a long sequence, as would +be done if it were called explicitly in @samp{test}. + +@lisp +;; => ((a . 1) (b . 2) (c . 4)) +(loopy (with (test #'car)) + (list i '((a . 1) (b . 2) (a . 3) (c . 4))) + (adjoin i :at end :key #'car)) + +;; Similary to the above: +;; +;; => ((a . 1) (b . 2) (c . 4)) +(loopy (with (test-val)) + (list i '((a . 1) (b . 2) (a . 3) (c . 4))) + (set test-val (car i)) + (adjoin i :test (lambda (seq-val _) + (equal (car seq-val) + test-val)))) +@end lisp @end table + The arguments to the @samp{test} and @samp{key} parameters can be quoted functions or variables, just like when using @code{cl-union}, @code{cl-adjoin}, and so on. @code{loopy} knows how to expand efficiently for either case. @@ -2809,12 +2875,12 @@ This command also has the alias @samp{summing}. @subsection Sequence Accumulation Sequence accumulation commands are used to join lists (such as @samp{union} and -@samp{append}) and to collect items into lists (such as @samp{collect}). +@samp{append}) and to collect items into lists (such as @samp{collect} and @samp{adjoin}). @findex adjoin @findex adjoining @table @asis -@item @samp{(adjoin VAR EXPR &key at test)} +@item @samp{(adjoin VAR EXPR &key at test key)} Repeatedly add @samp{EXPR} to @samp{VAR} if it is not already present in the list. @@ -2958,7 +3024,7 @@ apply wherever that value is used (@ref{Self-Evaluating Forms,,,elisp,}). @findex nunion @findex nunioning @table @asis -@item @samp{(nunion VAR EXPR &key test at)} +@item @samp{(nunion VAR EXPR &key test at key)} Repeatedly and @emph{destructively} insert into @samp{VAR} the elements of @samp{EXPR} which are not already present in @samp{VAR}. @@ -3036,7 +3102,7 @@ convenience. @findex union @findex unioning @table @asis -@item @samp{(union VAR EXPR &key test at)} +@item @samp{(union VAR EXPR &key test at key)} Repeatedly insert into @samp{VAR} the elements of the list @samp{EXPR} that are not already present in @samp{VAR}. @@ -4117,7 +4183,7 @@ using the @code{let*} special form. This method recognizes all commands and their aliases in the user option @code{loopy-aliases}. -@float Listing,org808789f +@float Listing,org0290e68 @lisp ;; => ((1 2 3) (-3 -2 -1) (0)) (loopy-iter (arg accum-opt positives negatives other) diff --git a/loopy-commands.el b/loopy-commands.el index f736ee9e..4987db66 100644 --- a/loopy-commands.el +++ b/loopy-commands.el @@ -1506,12 +1506,12 @@ more efficient than repeatedly traversing the list." (setq ,var (list ,val) ,last-link ,var))))))) -(defun loopy--produce-adjoin-end-tracking (var val membership-test) +(cl-defun loopy--produce-adjoin-end-tracking (var val &key test key) "Produce instructions for an end-tracking accumulation of single items. VAR is the variable whose end is to be tracked. VAL is the value -to be added to the end of VAR. MEMBERSHIP-TEST determines -whether VAL is already a member of VAR. This is used in +to be added to the end of VAR. TEST is the test function. KEY is +the transform function. This is used in accumulation commands like `adjoin'. For efficiency, accumulation commands use references to track the @@ -1521,23 +1521,28 @@ more efficient than repeatedly traversing the list." ;; for longer lists. (let ((last-link (loopy--get-accumulation-list-end-var loopy--loop-name var))) `((loopy--accumulation-vars (,last-link nil)) - (loopy--main-body - (cond - (,membership-test nil) - ;; If `last-link' is know, set it's cdr. - (,last-link - (setcdr ,last-link (list ,val)) - (setq ,last-link (cdr ,last-link))) - ;; If `var' was updated without `last-link', - ;; reset `last-link'. - (,var - (setq ,last-link (last ,var)) - (setcdr ,last-link (list ,val)) - (setq ,last-link (cdr ,last-link))) - ;; Otherwise, set `var' and `last-link' directly. - (t - (setq ,var (list ,val) - ,last-link ,var))))))) + ,@(loopy--instr-let2* ((test-val test) + (key-val key)) + loopy--accumulation-vars + `((loopy--main-body + ,(cl-once-only ((adjoin-value val)) + `(cond + ((loopy--member-p ,var ,adjoin-value :test ,test-val :key ,key-val) + nil) + ;; If `last-link' is know, set it's cdr. + (,last-link + (setcdr ,last-link (list ,adjoin-value)) + (setq ,last-link (cdr ,last-link))) + ;; If `var' was updated without `last-link', + ;; reset `last-link'. + (,var + (setq ,last-link (last ,var)) + (setcdr ,last-link (list ,adjoin-value)) + (setq ,last-link (cdr ,last-link))) + ;; Otherwise, set `var' and `last-link' directly. + (t + (setq ,var (list ,adjoin-value) + ,last-link ,var)))))))))) (defun loopy--produce-multi-item-end-tracking (var val &optional destructive) "Produce instructions for an end-tracking accumulation of copy-joined lists. @@ -1568,42 +1573,50 @@ more efficient than repeatedly traversing the list." (setq ,var ,accum-val ,last-link (last ,var)))))))) -(defun loopy--produce-union-end-tracking - (var val test-method &optional destructive) +(cl-defun loopy--produce-union-end-tracking + (var val &key test key destructive) "Produce instructions for an end-tracking accumulation of modify-joined lists. VAR is the variable whose end is to be tracked. VAL is the value -to be added to the end of VAR. TEST-METHOD is a function -returning t for any element in VAL that is already a member of -VAR. DESTRUCTIVE determines whether VAL is added to end of VAR -destructively. This is used in accumulation commands like -`union' and `nunion'. +to be added to the end of VAR. TEST is the function used to +determine presence. KEY is the transform function. DESTRUCTIVE +determines whether VAL is added to end of VAR destructively. +This is used in accumulation commands like `union' and `nunion'. For efficiency, accumulation commands use references to track the end location of the results list. For larger lists, this is much more efficient than repeatedly traversing the list." ;; End tracking is a bit slower than `nconc' for short ;; lists, but much faster for longer lists. - (let ((last-link (loopy--get-accumulation-list-end-var loopy--loop-name var)) - (accum-val (if destructive val `(copy-sequence ,val))) - (new-items (gensym "new-items"))) + (let ((last-link (loopy--get-accumulation-list-end-var loopy--loop-name var))) `((loopy--accumulation-vars (,last-link nil)) - (loopy--main-body - (if-let ((,new-items (cl-delete-if ,test-method ,accum-val))) - (cond - (,last-link - (setcdr ,last-link ,new-items) - (setq ,last-link (last ,last-link))) - (,var - (setq ,last-link (last ,var)) - (setcdr ,last-link ,new-items) - (setq ,last-link (last ,last-link))) - (t - (setq ,var ,new-items - ,last-link (last ,var))))))))) + ,@(loopy--instr-let2* ((test-val test) + (key-val key)) + loopy--accumulation-vars + `((loopy--main-body + ,(cl-with-gensyms (new-items) + `(if-let ((,new-items + (cl-delete-if ,(loopy--get-union-test-method + var + :test test-val + :key key-val) + ,(if destructive + val + `(copy-sequence ,val))))) + (cond + (,last-link + (setcdr ,last-link ,new-items) + (setq ,last-link (last ,last-link))) + (,var + (setq ,last-link (last ,var)) + (setcdr ,last-link ,new-items) + (setq ,last-link (last ,last-link))) + (t + (setq ,var ,new-items + ,last-link (last ,var)))))))))))) ;;;;;; Test Methods -(defun loopy--get-union-test-method (var &optional key test) +(cl-defun loopy--get-union-test-method (var &key key test) "Get a function testing for values in VAR in `union' and `nunion'. This function is fed to `cl-remove-if' or `cl-delete-if'. See @@ -1612,21 +1625,9 @@ the definitions of those commands for more context. TEST is use to check for equality (default `equal'). KEY modifies the inputs to test." ;; KEY applies to the value being tested as well as the elements in the list. - (let ((function-arg (gensym "union-function-arg"))) - `(lambda (,function-arg) - ,(if key - (let ((test-val (gensym "union-test-val")) - (test-var (gensym "union-test-var"))) - ;; Can't rely on lexical variables around a `lambda' in - ;; `cl-member-if', so we perform this part more manually. - `(cl-loop with ,test-val = ,(loopy--apply-function key - function-arg) - for ,test-var in ,var - thereis ,(loopy--apply-function - (or test (quote #'equal)) - (loopy--apply-function key test-var) - test-val))) - `(cl-member ,function-arg ,var :test ,test))))) + (cl-with-gensyms (arg) + `(lambda (,arg) + (loopy--member-p ,var ,arg :test ,test :key ,key)))) ;;;;;; Optimized Accumulations (defun loopy--expand-optimized-accum (arg) @@ -1893,43 +1894,25 @@ Warning trigger: %s" (map-let (('start start) ('end end)) (loopy--get-accum-counts loop var 'adjoin) - (let* ((val-is-expression (not (symbolp val))) - (value-holder (if val-is-expression - (gensym "adjoin-value") - val)) - (membership-test - ;; `adjoin' applies KEY to both the new item and old items in - ;; list, while `member' only applies KEY to items in the list. - ;; To be consistent and apply KEY to all items, we use - ;; `cl-member-if' with a custom predicate instead. - (if key - (let ((func-arg (gensym "adjoin-func-arg"))) - `(cl-member-if - (lambda (,func-arg) - ,(loopy--apply-function - (or test (quote #'equal)) - (loopy--apply-function key func-arg) - (loopy--apply-function key value-holder))) - ,var)) - `(cl-member ,value-holder ,var :test ,test)))) - + (let* ((at-start-instrs + (loopy--instr-let2* ((test-val test) + (key-val key)) + loopy--accumulation-vars + `((loopy--main-body + ,(cl-once-only ((adjoin-value val)) + `(unless (loopy--member-p ,var ,adjoin-value + :test ,test-val :key ,key-val) + (cl-callf2 cons ,adjoin-value ,var))))))) + (at-end-instrs (loopy--produce-adjoin-end-tracking var val + :test test :key key))) `((loopy--accumulation-vars (,var nil)) - ;; If the tested value is not already a variable, then we need to - ;; store so that we can check for its presence and then add it to the - ;; list. - ,@(when val-is-expression - `((loopy--accumulation-vars (,value-holder nil)) - (loopy--main-body (setq ,value-holder ,val)))) ,@(if (>= start end) ;; Create list in normal order. (progn (loopy--check-accumulation-compatibility loop var 'list cmd) `(,@(if (eq pos 'start) - `((loopy--main-body - (setq ,var (cl-adjoin ,value-holder ,var - :test ,test :key ,key)))) - (loopy--produce-adjoin-end-tracking var value-holder - membership-test)) + at-start-instrs + at-end-instrs) (loopy--vars-final-updates (,var . ,(if (eq 'list result-type) nil @@ -1938,11 +1921,8 @@ Warning trigger: %s" ;; Create list in reverse order. (loopy--check-accumulation-compatibility loop var 'reverse-list cmd) `(,@(if (eq pos 'start) - (loopy--produce-adjoin-end-tracking var value-holder - membership-test) - `((loopy--main-body (if ,membership-test - nil - (setq ,var (cons ,value-holder ,var)))))) + at-end-instrs + at-start-instrs) (loopy--vars-final-updates (,var . (setq ,var ,(if (eq 'list result-type) `(nreverse ,var) @@ -1978,33 +1958,16 @@ RESULT-TYPE can be used to `cl-coerce' the return value." `((loopy--accumulation-vars (,var nil)) ,@(cond ((member pos '(start beginning 'start 'beginning)) - `((loopy--main-body - (setq ,var (cl-adjoin ,val ,var :test ,test :key ,key))))) + (loopy--instr-let2* ((test-val test) + (key-val key)) + loopy--accumulation-vars + `((loopy--main-body + ,(cl-once-only ((adjoin-value val)) + `(unless (loopy--member-p ,var ,adjoin-value + :test ,test-val :key ,key-val) + (cl-callf2 cons ,adjoin-value ,var))))))) ((member pos '(end nil 'end)) - (let* ((val-is-expression (not (symbolp val))) - (value-holder (if val-is-expression - (gensym "adjoin-value") - val)) - (membership-test - ;; `adjoin' applies KEY to both the new item and old items in - ;; list, while `member' only applies KEY to items in the list. - ;; To be consistent and apply KEY to all items, we use - ;; `cl-member-if' with a custom predicate instead. - (if key - (let ((func-arg (gensym "adjoin-func-arg"))) - `(cl-member-if - (lambda (,func-arg) - ,(loopy--apply-function - (or test (quote #'equal)) - (loopy--apply-function key func-arg) - (loopy--apply-function key value-holder))) - ,var)) - `(cl-member ,value-holder ,var :test ,test)))) - `(,@(when val-is-expression - `((loopy--accumulation-vars (,value-holder nil)) - (loopy--main-body (setq ,value-holder ,val)))) - ,@(loopy--produce-adjoin-end-tracking var value-holder - membership-test)))) + (loopy--produce-adjoin-end-tracking var val :test test :key key)) (t (signal 'loopy-bad-position-command-argument (list pos cmd)))) (loopy--vars-final-updates @@ -2473,7 +2436,28 @@ This function is used by `loopy--expand-optimized-accum'." (loopy--plist-bind ( :cmd cmd :loop loop :var var :val val :at (pos 'end) :key key :test test) plist - (let ((test-method (loopy--get-union-test-method var key test))) + (cl-flet ((make-at-start (reverse) + (loopy--instr-let2* ((key-val key) + (test-val test)) + loopy--accumulation-vars + `((loopy--main-body + (setq ,var + (nconc ,(let ((del `(cl-delete-if ,(loopy--get-union-test-method + var + :test test-val + :key key-val) + ,val))) + (if reverse + `(nreverse ,del) + del)) + ,var)))))) + (make-at-end (reverse) + (loopy--produce-union-end-tracking var (if reverse + `(reverse ,val) + val) + :test test + :key key + :destructive t))) (map-let (('start start) ('end end)) (loopy--get-accum-counts loop var 'nunion) @@ -2483,18 +2467,15 @@ This function is used by `loopy--expand-optimized-accum'." (loopy--check-accumulation-compatibility loopy--loop-name var 'list cmd) `(,@(if (eq pos 'start) - `((loopy--main-body - (setq ,var (nconc (cl-delete-if ,test-method ,val) ,var)))) - (loopy--produce-union-end-tracking var val test-method 'destructive)) + (make-at-start nil) + (make-at-end nil)) (loopy--vars-final-updates (,var . nil)))) ;; Reverse list order. (loopy--check-accumulation-compatibility loopy--loop-name var 'reverse-list cmd) `(,@(if (eq pos 'start) - (loopy--produce-union-end-tracking var `(nreverse ,val) test-method 'destructive) - `((loopy--main-body - (setq ,var (nconc (nreverse (cl-delete-if ,test-method ,val)) - ,var))))) + (make-at-end t) + (make-at-start t)) (loopy--vars-final-updates (,var . (setq ,var (nreverse ,var)))))))))) @@ -2518,15 +2499,25 @@ This function is used by `loopy--expand-optimized-accum'." :key ,key :test ,test))))) (loopy--check-accumulation-compatibility loopy--loop-name var 'list cmd) `((loopy--accumulation-vars (,var nil)) - ,@(let ((test-method (loopy--get-union-test-method var key test))) - (cond - ((member pos '(start beginning 'start 'beginning)) + ,@(cond + ((member pos '(start beginning 'start 'beginning)) + (loopy--instr-let2* ((test-val test) + (key-val key)) + loopy--accumulation-vars `((loopy--main-body - (setq ,var (nconc (cl-delete-if ,test-method ,val) ,var))))) - ((member pos '(end 'end)) - (loopy--produce-union-end-tracking var val test-method 'destructive)) - (t - (signal 'loopy-bad-position-command-argument (list pos cmd))))) + (setq ,var (nconc (cl-delete-if + ,(loopy--get-union-test-method var + :test test-val + :key key-val) + ,val) + ,var)))))) + ((member pos '(end 'end)) + (loopy--produce-union-end-tracking var val + :test test + :key key + :destructive t)) + (t + (signal 'loopy-bad-position-command-argument (list pos cmd)))) (loopy--vars-final-updates (,var . nil))))) :implicit (loopy--plist-bind (:at (pos 'end) :key key :test (test (quote #'equal))) @@ -2634,7 +2625,28 @@ This function is used by `loopy--expand-optimized-accum'." (loopy--plist-bind ( :cmd cmd :loop loop :var var :val val :at (pos 'end) :key key :test test) plist - (let ((test-method (loopy--get-union-test-method var key test))) + (cl-flet ((make-at-start (reverse) + (loopy--instr-let2* ((key-val key) + (test-val test)) + loopy--accumulation-vars + `((loopy--main-body + (setq ,var + (nconc ,(let ((del `(cl-delete-if ,(loopy--get-union-test-method + var + :test test-val + :key key-val) + (copy-sequence ,val)))) + (if reverse + `(nreverse ,del) + del)) + ,var)))))) + (make-at-end (reverse) + (loopy--produce-union-end-tracking var (if reverse + `(reverse ,val) + val) + :test test + :key key + :destructive nil))) (map-let (('start start) ('end end)) (loopy--get-accum-counts loop var 'union) @@ -2644,22 +2656,15 @@ This function is used by `loopy--expand-optimized-accum'." (loopy--check-accumulation-compatibility loopy--loop-name var 'list cmd) `(,@(if (eq pos 'start) - `((loopy--main-body - (setq ,var - (nconc (cl-delete-if ,test-method (copy-sequence ,val)) - ,var)))) - (loopy--produce-union-end-tracking var val test-method)) + (make-at-start nil) + (make-at-end nil)) (loopy--vars-final-updates (,var . nil)))) ;; Reverse list order. (loopy--check-accumulation-compatibility loopy--loop-name var 'reverse-list cmd) `(,@(if (eq pos 'start) - (loopy--produce-union-end-tracking var `(reverse ,val) - test-method) - `((loopy--main-body - (setq ,var (nconc (nreverse (cl-delete-if ,test-method - (copy-sequence ,val))) - ,var))))) + (make-at-end t) + (make-at-start t)) (loopy--vars-final-updates (,var . (setq ,var (nreverse ,var)))))))))) @@ -2679,16 +2684,25 @@ This function is used by `loopy--expand-optimized-accum'." :key ,key :test ,test))))) (loopy--check-accumulation-compatibility loopy--loop-name var 'list cmd) `((loopy--accumulation-vars (,var nil)) - ,@(let ((test-method (loopy--get-union-test-method var key test))) - (cond - ((member pos '(start beginning 'start 'beginning)) + ,@(cond + ((member pos '(start beginning 'start 'beginning)) + (loopy--instr-let2* ((test-val test) + (key-val key)) + loopy--accumulation-vars `((loopy--main-body - (setq ,var (nconc (cl-delete-if ,test-method (copy-sequence ,val)) - ,var))))) - ((member pos '(end 'end)) - (loopy--produce-union-end-tracking var val test-method)) - (t - (signal 'loopy-bad-position-command-argument (list pos cmd))))) + (setq ,var (nconc (cl-delete-if + ,(loopy--get-union-test-method var + :test test-val + :key key-val) + (copy-sequence ,val)) + ,var)))))) + ((member pos '(end 'end)) + (loopy--produce-union-end-tracking var val + :test test + :key key + :destructive nil)) + (t + (signal 'loopy-bad-position-command-argument (list pos cmd)))) (loopy--vars-final-updates (,var . nil))))) :implicit (loopy--plist-bind (:at (pos 'end) :key key :test (test (quote #'equal))) diff --git a/loopy-misc.el b/loopy-misc.el index 45cdbf8e..25922452 100644 --- a/loopy-misc.el +++ b/loopy-misc.el @@ -199,48 +199,28 @@ For example, applying `cl-oddp' on (2 4 6 7) returns 3." This is helpful when working with property lists." (cl-loop for i in list by #'cddr collect i)) -;; TODO: Would this be more useful as a `pcase' macro? - -;; Note: This macro cannot currently be replaced by `cl-destructuring-bind' or -;; `map-let'. -;; - `map-let' provides no way to specify a default value when a key is -;; not in PLIST. This macro does. -;; - `cl-destructuring-bind' signals an error when a key is in PLIST that -;; is not in BINDINGS. This macro does not. (defmacro loopy--plist-bind (bindings plist &rest body) "Bind values in PLIST to variables in BINDINGS, surrounding BODY. - PLIST is a property list. -- BINDINGS is of the form (KEY VAR KEY VAR ...). VAR can - optionally be a list of two elements: a variable name and a - default value, similar to what one would use for expressing - keyword parameters in `cl-defun' or `cl-destructuring-bind'. - The default value is used /only/ when KEY is not found in - PLIST. +- BINDINGS is of the form (KEY VAR KEY VAR ...). VAR has the + form (NAME [DEFAULT [PROVIDED]]) as in `cl-destructuring-bind'. - BODY is the same as in `let'. -This macro works the same as `cl-destructuring-bind', except for -the case when keys exist in PLIST that are not listed in -BINDINGS. While `cl-destructuring-bind' would signal an error, -this macro simply ignores them." +This is a wrapper around `cl-destructuring-bind'. The difference is +that we do not need to specify `&allow-other-keys' and that +keywords and variables are separate." (declare (indent 2)) - (let ((value-holder (gensym "plist-let-")) - (found-key (gensym "plist-prop-found-"))) - `(let* ((,value-holder ,plist) - ,@(cl-loop for (key var . _) on bindings by #'cddr - if (consp var) - collect `(,(cl-first var) - ;; Use `plist-member' instead of `plist-get' to - ;; allow giving `nil' as an argument without - ;; using the default value. - (if-let ((,found-key (plist-member ,value-holder - ,key))) - (cl-second ,found-key) - ,(cl-second var))) - else collect `(,var (plist-get ,value-holder ,key)))) - ,@body))) + `(cl-destructuring-bind (&key + ,@(cl-loop for (key var . _) on bindings by #'cddr + if (consp var) + collect `((,key ,(cl-first var)) ,@(cdr var)) + else collect `((,key ,var))) + &allow-other-keys) + ,plist + ,@body)) (cl-defun loopy--substitute-using (new seq &key test) "Copy SEQ, substituting elements using output of function NEW. @@ -1115,5 +1095,89 @@ Returns a list of instructions." (setq ,index-holder (,(if decreasing #'- #'+) ,index-holder ,increment-holder)))))) + +;;;; Membership + +(cl-defun loopy--member-p (list element &key (test #'equal) key) + "Check whether ELEMENT is in LIST using TEST. + +KEY is applied to both ELEMENT and the sequences of the list. + +This function is like `seq-contains-p' and `cl-member', +but TEST is guaranteed to receive the value from the list +first and ELEMENT second." + ;; `adjoin' applies KEY to both the new item and old items in + ;; list, while `member' only applies KEY to items in the list. + ;; To be consistent and apply KEY to all items, we use + ;; `cl-member-if' with a custom predicate instead. + ;; + ;; The CLHS is wrong in how `adjoin' works. See #170. + (declare (compiler-macro loopy--member-p-comp)) + (setq test (or test #'equal)) + (if key + (cl-loop with test-val = (funcall key element) + for i in list + thereis (funcall test (funcall key i) test-val)) + (pcase test + ('equal (member element list)) + ('eql (memql element list)) + ('eq (memq element list)) + (_ (cl-loop for i in list + thereis (funcall test i element)))))) + +(cl-defun loopy--member-p-comp (form list element &key (test '#'equal) key) + "Expand `loopy--member-p' to a more efficient function when possible." + (if key + (cl-with-gensyms (test-val seq-val) + `(cl-loop with ,test-val = (funcall ,key ,element) + for ,seq-val in ,list + thereis (funcall ,test (funcall ,key ,seq-val) ,test-val))) + ;; This logic take from `cl--constr-expr-p'. + (pcase (let ((test (macroexpand-all test macroexpand-all-environment))) + (if (macroexp-const-p test) + (if (consp test) + (nth 1 test) + test))) + ('equal `(member ,element ,list)) + ('eql `(memql ,element ,list)) + ('eq `(memq ,element ,list)) + (_ form)))) + +;;;; Variable binding for instructions + +(defmacro loopy--instr-let2 (place sym exp &rest body) + "Use SYM as EXP for BODY, maybe creating an instruction to bind at PLACE. + +See also `macroexp-let2'." + (declare (indent 3)) + (let ((bodysym (gensym "body")) + (expsym (gensym "exp")) + (val-holder (gensym (format "new-" sym)))) + `(let* ((,expsym ,exp) + (,sym (if (macroexp-const-p ,expsym) + ,expsym + (quote ,val-holder))) + (,bodysym (progn ,@body))) + (if (eq ,sym ,expsym) + ,bodysym + ,(macroexp-let* (list (list sym expsym)) + `(cons (list (quote ,place) + (list (quote ,val-holder) ,expsym)) + ,bodysym)))))) + +(defmacro loopy--instr-let2* (bindings place &rest body) + "A multi-binding version of `loopy--instr-let2'. + +BINDINGS are variable-value pairs. PLACE is the Loopy variable to use +as the head of the instruction. BODY are the forms for which the +binding exists." + (declare (indent 2)) + (cl-loop with res = (macroexp-progn body) + for (var val) in (reverse bindings) + do (setq res + `(loopy--instr-let2 ,place ,var ,val + ,res)) + finally return res)) + (provide 'loopy-misc) ;;; loopy-misc.el ends here diff --git a/tests/misc-tests.el b/tests/misc-tests.el index 6710e095..3ba63707 100644 --- a/tests/misc-tests.el +++ b/tests/misc-tests.el @@ -23,6 +23,19 @@ INPUT is the destructuring usage. OUTPUT-PATTERN is what to match." (should (equal '((a b c) d) (loopy--split-off-last-var '(a b c . d))))) +(ert-deftest loopy--member-p () + (should (loopy--member-p '((a . 1) (b . 2)) + '(2 . c) + :test + (lambda (seq-val test-val) + (= (cdr seq-val) + (car test-val))))) + (should (loopy--member-p '((1) (2) (3)) '(2))) + (should (loopy--member-p '((1) (2) (3)) '(2) :test #'equal)) + (should-error (loopy--member-p '((1) (2) (3)) '(2) :test #'=)) + (should (loopy--member-p '(1 2 3) 2 :test #'=)) + (should (loopy--member-p '((1) (2) (3)) '(2) :test #'= :key #'car))) + ;;; Destructuring (ert-deftest destructure-array-errors ()