commit | author | age
|
5cb5f7
|
1 |
;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*- |
C |
2 |
|
|
3 |
;; Copyright (C) 2012-2016 Free Software Foundation, Inc. |
|
4 |
|
|
5 |
;; Author: Magnar Sveen <magnars@gmail.com> |
|
6 |
;; Version: 2.14.1 |
|
7 |
;; Package-Version: 20180910.1856 |
|
8 |
;; Keywords: lists |
|
9 |
|
|
10 |
;; This program is free software; you can redistribute it and/or modify |
|
11 |
;; it under the terms of the GNU General Public License as published by |
|
12 |
;; the Free Software Foundation, either version 3 of the License, or |
|
13 |
;; (at your option) any later version. |
|
14 |
|
|
15 |
;; This program is distributed in the hope that it will be useful, |
|
16 |
;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
17 |
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
18 |
;; GNU General Public License for more details. |
|
19 |
|
|
20 |
;; You should have received a copy of the GNU General Public License |
|
21 |
;; along with this program. If not, see <http://www.gnu.org/licenses/>. |
|
22 |
|
|
23 |
;;; Commentary: |
|
24 |
|
|
25 |
;; A modern list api for Emacs. |
|
26 |
;; |
|
27 |
;; See documentation on https://github.com/magnars/dash.el#functions |
|
28 |
;; |
|
29 |
;; **Please note** The lexical binding in this file is not utilised at the |
|
30 |
;; moment. We will take full advantage of lexical binding in an upcoming 3.0 |
|
31 |
;; release of Dash. In the meantime, we've added the pragma to avoid a bug that |
|
32 |
;; you can read more about in https://github.com/magnars/dash.el/issues/130. |
|
33 |
;; |
|
34 |
|
|
35 |
;;; Code: |
|
36 |
|
|
37 |
(defgroup dash () |
|
38 |
"Customize group for dash.el" |
|
39 |
:group 'lisp |
|
40 |
:prefix "dash-") |
|
41 |
|
|
42 |
(defun dash--enable-fontlock (symbol value) |
|
43 |
(when value |
|
44 |
(dash-enable-font-lock)) |
|
45 |
(set-default symbol value)) |
|
46 |
|
|
47 |
(defcustom dash-enable-fontlock nil |
|
48 |
"If non-nil, enable fontification of dash functions, macros and |
|
49 |
special values." |
|
50 |
:type 'boolean |
|
51 |
:set 'dash--enable-fontlock |
|
52 |
:group 'dash) |
|
53 |
|
|
54 |
(defmacro !cons (car cdr) |
|
55 |
"Destructive: Set CDR to the cons of CAR and CDR." |
|
56 |
`(setq ,cdr (cons ,car ,cdr))) |
|
57 |
|
|
58 |
(defmacro !cdr (list) |
|
59 |
"Destructive: Set LIST to the cdr of LIST." |
|
60 |
`(setq ,list (cdr ,list))) |
|
61 |
|
|
62 |
(defmacro --each (list &rest body) |
|
63 |
"Anaphoric form of `-each'." |
|
64 |
(declare (debug (form body)) |
|
65 |
(indent 1)) |
|
66 |
(let ((l (make-symbol "list"))) |
|
67 |
`(let ((,l ,list) |
|
68 |
(it-index 0)) |
|
69 |
(while ,l |
|
70 |
(let ((it (car ,l))) |
|
71 |
,@body) |
|
72 |
(setq it-index (1+ it-index)) |
|
73 |
(!cdr ,l))))) |
|
74 |
|
|
75 |
(defmacro -doto (eval-initial-value &rest forms) |
|
76 |
"Eval a form, then insert that form as the 2nd argument to other forms. |
|
77 |
The EVAL-INITIAL-VALUE form is evaluated once. Its result is |
|
78 |
passed to FORMS, which are then evaluated sequentially. Returns |
|
79 |
the target form." |
|
80 |
(declare (indent 1)) |
|
81 |
(let ((retval (make-symbol "value"))) |
|
82 |
`(let ((,retval ,eval-initial-value)) |
|
83 |
,@(mapcar (lambda (form) |
|
84 |
(if (sequencep form) |
|
85 |
`(,(-first-item form) ,retval ,@(cdr form)) |
|
86 |
`(funcall form ,retval))) |
|
87 |
forms) |
|
88 |
,retval))) |
|
89 |
|
|
90 |
(defun -each (list fn) |
|
91 |
"Call FN with every item in LIST. Return nil, used for side-effects only." |
|
92 |
(--each list (funcall fn it))) |
|
93 |
|
|
94 |
(put '-each 'lisp-indent-function 1) |
|
95 |
|
|
96 |
(defalias '--each-indexed '--each) |
|
97 |
|
|
98 |
(defun -each-indexed (list fn) |
|
99 |
"Call (FN index item) for each item in LIST. |
|
100 |
|
|
101 |
In the anaphoric form `--each-indexed', the index is exposed as symbol `it-index'. |
|
102 |
|
|
103 |
See also: `-map-indexed'." |
|
104 |
(--each list (funcall fn it-index it))) |
|
105 |
(put '-each-indexed 'lisp-indent-function 1) |
|
106 |
|
|
107 |
(defmacro --each-while (list pred &rest body) |
|
108 |
"Anaphoric form of `-each-while'." |
|
109 |
(declare (debug (form form body)) |
|
110 |
(indent 2)) |
|
111 |
(let ((l (make-symbol "list")) |
|
112 |
(c (make-symbol "continue"))) |
|
113 |
`(let ((,l ,list) |
|
114 |
(,c t) |
|
115 |
(it-index 0)) |
|
116 |
(while (and ,l ,c) |
|
117 |
(let ((it (car ,l))) |
|
118 |
(if (not ,pred) (setq ,c nil) ,@body)) |
|
119 |
(setq it-index (1+ it-index)) |
|
120 |
(!cdr ,l))))) |
|
121 |
|
|
122 |
(defun -each-while (list pred fn) |
|
123 |
"Call FN with every item in LIST while (PRED item) is non-nil. |
|
124 |
Return nil, used for side-effects only." |
|
125 |
(--each-while list (funcall pred it) (funcall fn it))) |
|
126 |
|
|
127 |
(put '-each-while 'lisp-indent-function 2) |
|
128 |
|
|
129 |
(defmacro --each-r (list &rest body) |
|
130 |
"Anaphoric form of `-each-r'." |
|
131 |
(declare (debug (form body)) |
|
132 |
(indent 1)) |
|
133 |
(let ((v (make-symbol "vector"))) |
|
134 |
;; Implementation note: building vector is considerably faster |
|
135 |
;; than building a reversed list (vector takes less memory, so |
|
136 |
;; there is less GC), plus length comes naturally. In-place |
|
137 |
;; 'nreverse' would be faster still, but BODY would be able to see |
|
138 |
;; that, even if modification was reversed before we return. |
|
139 |
`(let* ((,v (vconcat ,list)) |
|
140 |
(it-index (length ,v)) |
|
141 |
it) |
|
142 |
(while (> it-index 0) |
|
143 |
(setq it-index (1- it-index)) |
|
144 |
(setq it (aref ,v it-index)) |
|
145 |
,@body)))) |
|
146 |
|
|
147 |
(defun -each-r (list fn) |
|
148 |
"Call FN with every item in LIST in reversed order. |
|
149 |
Return nil, used for side-effects only." |
|
150 |
(--each-r list (funcall fn it))) |
|
151 |
|
|
152 |
(defmacro --each-r-while (list pred &rest body) |
|
153 |
"Anaphoric form of `-each-r-while'." |
|
154 |
(declare (debug (form form body)) |
|
155 |
(indent 2)) |
|
156 |
(let ((v (make-symbol "vector"))) |
|
157 |
`(let* ((,v (vconcat ,list)) |
|
158 |
(it-index (length ,v)) |
|
159 |
it) |
|
160 |
(while (> it-index 0) |
|
161 |
(setq it-index (1- it-index)) |
|
162 |
(setq it (aref ,v it-index)) |
|
163 |
(if (not ,pred) |
|
164 |
(setq it-index -1) |
|
165 |
,@body))))) |
|
166 |
|
|
167 |
(defun -each-r-while (list pred fn) |
|
168 |
"Call FN with every item in reversed LIST while (PRED item) is non-nil. |
|
169 |
Return nil, used for side-effects only." |
|
170 |
(--each-r-while list (funcall pred it) (funcall fn it))) |
|
171 |
|
|
172 |
(defmacro --dotimes (num &rest body) |
|
173 |
"Repeatedly executes BODY (presumably for side-effects) with symbol `it' bound to integers from 0 through NUM-1." |
|
174 |
(declare (debug (form body)) |
|
175 |
(indent 1)) |
|
176 |
(let ((n (make-symbol "num"))) |
|
177 |
`(let ((,n ,num) |
|
178 |
(it 0)) |
|
179 |
(while (< it ,n) |
|
180 |
,@body |
|
181 |
(setq it (1+ it)))))) |
|
182 |
|
|
183 |
(defun -dotimes (num fn) |
|
184 |
"Repeatedly calls FN (presumably for side-effects) passing in integers from 0 through NUM-1." |
|
185 |
(--dotimes num (funcall fn it))) |
|
186 |
|
|
187 |
(put '-dotimes 'lisp-indent-function 1) |
|
188 |
|
|
189 |
(defun -map (fn list) |
|
190 |
"Return a new list consisting of the result of applying FN to the items in LIST." |
|
191 |
(mapcar fn list)) |
|
192 |
|
|
193 |
(defmacro --map (form list) |
|
194 |
"Anaphoric form of `-map'." |
|
195 |
(declare (debug (form form))) |
|
196 |
`(mapcar (lambda (it) ,form) ,list)) |
|
197 |
|
|
198 |
(defmacro --reduce-from (form initial-value list) |
|
199 |
"Anaphoric form of `-reduce-from'." |
|
200 |
(declare (debug (form form form))) |
|
201 |
`(let ((acc ,initial-value)) |
|
202 |
(--each ,list (setq acc ,form)) |
|
203 |
acc)) |
|
204 |
|
|
205 |
(defun -reduce-from (fn initial-value list) |
|
206 |
"Return the result of applying FN to INITIAL-VALUE and the |
|
207 |
first item in LIST, then applying FN to that result and the 2nd |
|
208 |
item, etc. If LIST contains no items, return INITIAL-VALUE and |
|
209 |
do not call FN. |
|
210 |
|
|
211 |
In the anaphoric form `--reduce-from', the accumulated value is |
|
212 |
exposed as symbol `acc'. |
|
213 |
|
|
214 |
See also: `-reduce', `-reduce-r'" |
|
215 |
(--reduce-from (funcall fn acc it) initial-value list)) |
|
216 |
|
|
217 |
(defmacro --reduce (form list) |
|
218 |
"Anaphoric form of `-reduce'." |
|
219 |
(declare (debug (form form))) |
|
220 |
(let ((lv (make-symbol "list-value"))) |
|
221 |
`(let ((,lv ,list)) |
|
222 |
(if ,lv |
|
223 |
(--reduce-from ,form (car ,lv) (cdr ,lv)) |
|
224 |
(let (acc it) ,form))))) |
|
225 |
|
|
226 |
(defun -reduce (fn list) |
|
227 |
"Return the result of applying FN to the first 2 items in LIST, |
|
228 |
then applying FN to that result and the 3rd item, etc. If LIST |
|
229 |
contains no items, return the result of calling FN with no |
|
230 |
arguments. If LIST contains a single item, return that item |
|
231 |
and do not call FN. |
|
232 |
|
|
233 |
In the anaphoric form `--reduce', the accumulated value is |
|
234 |
exposed as symbol `acc'. |
|
235 |
|
|
236 |
See also: `-reduce-from', `-reduce-r'" |
|
237 |
(if list |
|
238 |
(-reduce-from fn (car list) (cdr list)) |
|
239 |
(funcall fn))) |
|
240 |
|
|
241 |
(defmacro --reduce-r-from (form initial-value list) |
|
242 |
"Anaphoric version of `-reduce-r-from'." |
|
243 |
(declare (debug (form form form))) |
|
244 |
`(--reduce-from ,form ,initial-value (reverse ,list))) |
|
245 |
|
|
246 |
(defun -reduce-r-from (fn initial-value list) |
|
247 |
"Replace conses with FN, nil with INITIAL-VALUE and evaluate |
|
248 |
the resulting expression. If LIST is empty, INITIAL-VALUE is |
|
249 |
returned and FN is not called. |
|
250 |
|
|
251 |
Note: this function works the same as `-reduce-from' but the |
|
252 |
operation associates from right instead of from left. |
|
253 |
|
|
254 |
See also: `-reduce-r', `-reduce'" |
|
255 |
(--reduce-r-from (funcall fn it acc) initial-value list)) |
|
256 |
|
|
257 |
(defmacro --reduce-r (form list) |
|
258 |
"Anaphoric version of `-reduce-r'." |
|
259 |
(declare (debug (form form))) |
|
260 |
`(--reduce ,form (reverse ,list))) |
|
261 |
|
|
262 |
(defun -reduce-r (fn list) |
|
263 |
"Replace conses with FN and evaluate the resulting expression. |
|
264 |
The final nil is ignored. If LIST contains no items, return the |
|
265 |
result of calling FN with no arguments. If LIST contains a single |
|
266 |
item, return that item and do not call FN. |
|
267 |
|
|
268 |
The first argument of FN is the new item, the second is the |
|
269 |
accumulated value. |
|
270 |
|
|
271 |
Note: this function works the same as `-reduce' but the operation |
|
272 |
associates from right instead of from left. |
|
273 |
|
|
274 |
See also: `-reduce-r-from', `-reduce'" |
|
275 |
(if list |
|
276 |
(--reduce-r (funcall fn it acc) list) |
|
277 |
(funcall fn))) |
|
278 |
|
|
279 |
(defun -reductions-from (fn init list) |
|
280 |
"Return a list of the intermediate values of the reduction. |
|
281 |
|
|
282 |
See `-reduce-from' for explanation of the arguments. |
|
283 |
|
|
284 |
See also: `-reductions', `-reductions-r', `-reduce-r'" |
|
285 |
(nreverse (--reduce-from (cons (funcall fn (car acc) it) acc) (list init) list))) |
|
286 |
|
|
287 |
(defun -reductions (fn list) |
|
288 |
"Return a list of the intermediate values of the reduction. |
|
289 |
|
|
290 |
See `-reduce' for explanation of the arguments. |
|
291 |
|
|
292 |
See also: `-reductions-from', `-reductions-r', `-reduce-r'" |
|
293 |
(and list (-reductions-from fn (car list) (cdr list)))) |
|
294 |
|
|
295 |
(defun -reductions-r-from (fn init list) |
|
296 |
"Return a list of the intermediate values of the reduction. |
|
297 |
|
|
298 |
See `-reduce-r-from' for explanation of the arguments. |
|
299 |
|
|
300 |
See also: `-reductions-r', `-reductions', `-reduce'" |
|
301 |
(--reduce-r-from (cons (funcall fn it (car acc)) acc) (list init) list)) |
|
302 |
|
|
303 |
(defun -reductions-r (fn list) |
|
304 |
"Return a list of the intermediate values of the reduction. |
|
305 |
|
|
306 |
See `-reduce-r' for explanation of the arguments. |
|
307 |
|
|
308 |
See also: `-reductions-r-from', `-reductions', `-reduce'" |
|
309 |
(when list |
|
310 |
(let ((rev (reverse list))) |
|
311 |
(--reduce-from (cons (funcall fn it (car acc)) acc) |
|
312 |
(list (car rev)) |
|
313 |
(cdr rev))))) |
|
314 |
|
|
315 |
(defmacro --filter (form list) |
|
316 |
"Anaphoric form of `-filter'. |
|
317 |
|
|
318 |
See also: `--remove'." |
|
319 |
(declare (debug (form form))) |
|
320 |
(let ((r (make-symbol "result"))) |
|
321 |
`(let (,r) |
|
322 |
(--each ,list (when ,form (!cons it ,r))) |
|
323 |
(nreverse ,r)))) |
|
324 |
|
|
325 |
(defun -filter (pred list) |
|
326 |
"Return a new list of the items in LIST for which PRED returns a non-nil value. |
|
327 |
|
|
328 |
Alias: `-select' |
|
329 |
|
|
330 |
See also: `-keep', `-remove'." |
|
331 |
(--filter (funcall pred it) list)) |
|
332 |
|
|
333 |
(defalias '-select '-filter) |
|
334 |
(defalias '--select '--filter) |
|
335 |
|
|
336 |
(defmacro --remove (form list) |
|
337 |
"Anaphoric form of `-remove'. |
|
338 |
|
|
339 |
See also `--filter'." |
|
340 |
(declare (debug (form form))) |
|
341 |
`(--filter (not ,form) ,list)) |
|
342 |
|
|
343 |
(defun -remove (pred list) |
|
344 |
"Return a new list of the items in LIST for which PRED returns nil. |
|
345 |
|
|
346 |
Alias: `-reject' |
|
347 |
|
|
348 |
See also: `-filter'." |
|
349 |
(--remove (funcall pred it) list)) |
|
350 |
|
|
351 |
(defalias '-reject '-remove) |
|
352 |
(defalias '--reject '--remove) |
|
353 |
|
|
354 |
(defun -remove-first (pred list) |
|
355 |
"Return a new list with the first item matching PRED removed. |
|
356 |
|
|
357 |
Alias: `-reject-first' |
|
358 |
|
|
359 |
See also: `-remove', `-map-first'" |
|
360 |
(let (front) |
|
361 |
(while (and list (not (funcall pred (car list)))) |
|
362 |
(push (car list) front) |
|
363 |
(!cdr list)) |
|
364 |
(if list |
|
365 |
(-concat (nreverse front) (cdr list)) |
|
366 |
(nreverse front)))) |
|
367 |
|
|
368 |
(defmacro --remove-first (form list) |
|
369 |
"Anaphoric form of `-remove-first'." |
|
370 |
(declare (debug (form form))) |
|
371 |
`(-remove-first (lambda (it) ,form) ,list)) |
|
372 |
|
|
373 |
(defalias '-reject-first '-remove-first) |
|
374 |
(defalias '--reject-first '--remove-first) |
|
375 |
|
|
376 |
(defun -remove-last (pred list) |
|
377 |
"Return a new list with the last item matching PRED removed. |
|
378 |
|
|
379 |
Alias: `-reject-last' |
|
380 |
|
|
381 |
See also: `-remove', `-map-last'" |
|
382 |
(nreverse (-remove-first pred (reverse list)))) |
|
383 |
|
|
384 |
(defmacro --remove-last (form list) |
|
385 |
"Anaphoric form of `-remove-last'." |
|
386 |
(declare (debug (form form))) |
|
387 |
`(-remove-last (lambda (it) ,form) ,list)) |
|
388 |
|
|
389 |
(defalias '-reject-last '-remove-last) |
|
390 |
(defalias '--reject-last '--remove-last) |
|
391 |
|
|
392 |
(defun -remove-item (item list) |
|
393 |
"Remove all occurences of ITEM from LIST. |
|
394 |
|
|
395 |
Comparison is done with `equal'." |
|
396 |
(declare (pure t) (side-effect-free t)) |
|
397 |
(--remove (equal it item) list)) |
|
398 |
|
|
399 |
(defmacro --keep (form list) |
|
400 |
"Anaphoric form of `-keep'." |
|
401 |
(declare (debug (form form))) |
|
402 |
(let ((r (make-symbol "result")) |
|
403 |
(m (make-symbol "mapped"))) |
|
404 |
`(let (,r) |
|
405 |
(--each ,list (let ((,m ,form)) (when ,m (!cons ,m ,r)))) |
|
406 |
(nreverse ,r)))) |
|
407 |
|
|
408 |
(defun -keep (fn list) |
|
409 |
"Return a new list of the non-nil results of applying FN to the items in LIST. |
|
410 |
|
|
411 |
If you want to select the original items satisfying a predicate use `-filter'." |
|
412 |
(--keep (funcall fn it) list)) |
|
413 |
|
|
414 |
(defun -non-nil (list) |
|
415 |
"Return all non-nil elements of LIST." |
|
416 |
(declare (pure t) (side-effect-free t)) |
|
417 |
(-remove 'null list)) |
|
418 |
|
|
419 |
(defmacro --map-indexed (form list) |
|
420 |
"Anaphoric form of `-map-indexed'." |
|
421 |
(declare (debug (form form))) |
|
422 |
(let ((r (make-symbol "result"))) |
|
423 |
`(let (,r) |
|
424 |
(--each ,list |
|
425 |
(!cons ,form ,r)) |
|
426 |
(nreverse ,r)))) |
|
427 |
|
|
428 |
(defun -map-indexed (fn list) |
|
429 |
"Return a new list consisting of the result of (FN index item) for each item in LIST. |
|
430 |
|
|
431 |
In the anaphoric form `--map-indexed', the index is exposed as symbol `it-index'. |
|
432 |
|
|
433 |
See also: `-each-indexed'." |
|
434 |
(--map-indexed (funcall fn it-index it) list)) |
|
435 |
|
|
436 |
(defmacro --map-when (pred rep list) |
|
437 |
"Anaphoric form of `-map-when'." |
|
438 |
(declare (debug (form form form))) |
|
439 |
(let ((r (make-symbol "result"))) |
|
440 |
`(let (,r) |
|
441 |
(--each ,list (!cons (if ,pred ,rep it) ,r)) |
|
442 |
(nreverse ,r)))) |
|
443 |
|
|
444 |
(defun -map-when (pred rep list) |
|
445 |
"Return a new list where the elements in LIST that do not match the PRED function |
|
446 |
are unchanged, and where the elements in LIST that do match the PRED function are mapped |
|
447 |
through the REP function. |
|
448 |
|
|
449 |
Alias: `-replace-where' |
|
450 |
|
|
451 |
See also: `-update-at'" |
|
452 |
(--map-when (funcall pred it) (funcall rep it) list)) |
|
453 |
|
|
454 |
(defalias '-replace-where '-map-when) |
|
455 |
(defalias '--replace-where '--map-when) |
|
456 |
|
|
457 |
(defun -map-first (pred rep list) |
|
458 |
"Replace first item in LIST satisfying PRED with result of REP called on this item. |
|
459 |
|
|
460 |
See also: `-map-when', `-replace-first'" |
|
461 |
(let (front) |
|
462 |
(while (and list (not (funcall pred (car list)))) |
|
463 |
(push (car list) front) |
|
464 |
(!cdr list)) |
|
465 |
(if list |
|
466 |
(-concat (nreverse front) (cons (funcall rep (car list)) (cdr list))) |
|
467 |
(nreverse front)))) |
|
468 |
|
|
469 |
(defmacro --map-first (pred rep list) |
|
470 |
"Anaphoric form of `-map-first'." |
|
471 |
`(-map-first (lambda (it) ,pred) (lambda (it) (ignore it) ,rep) ,list)) |
|
472 |
|
|
473 |
(defun -map-last (pred rep list) |
|
474 |
"Replace last item in LIST satisfying PRED with result of REP called on this item. |
|
475 |
|
|
476 |
See also: `-map-when', `-replace-last'" |
|
477 |
(nreverse (-map-first pred rep (reverse list)))) |
|
478 |
|
|
479 |
(defmacro --map-last (pred rep list) |
|
480 |
"Anaphoric form of `-map-last'." |
|
481 |
`(-map-last (lambda (it) ,pred) (lambda (it) (ignore it) ,rep) ,list)) |
|
482 |
|
|
483 |
(defun -replace (old new list) |
|
484 |
"Replace all OLD items in LIST with NEW. |
|
485 |
|
|
486 |
Elements are compared using `equal'. |
|
487 |
|
|
488 |
See also: `-replace-at'" |
|
489 |
(declare (pure t) (side-effect-free t)) |
|
490 |
(--map-when (equal it old) new list)) |
|
491 |
|
|
492 |
(defun -replace-first (old new list) |
|
493 |
"Replace the first occurence of OLD with NEW in LIST. |
|
494 |
|
|
495 |
Elements are compared using `equal'. |
|
496 |
|
|
497 |
See also: `-map-first'" |
|
498 |
(declare (pure t) (side-effect-free t)) |
|
499 |
(--map-first (equal old it) new list)) |
|
500 |
|
|
501 |
(defun -replace-last (old new list) |
|
502 |
"Replace the last occurence of OLD with NEW in LIST. |
|
503 |
|
|
504 |
Elements are compared using `equal'. |
|
505 |
|
|
506 |
See also: `-map-last'" |
|
507 |
(declare (pure t) (side-effect-free t)) |
|
508 |
(--map-last (equal old it) new list)) |
|
509 |
|
|
510 |
(defmacro --mapcat (form list) |
|
511 |
"Anaphoric form of `-mapcat'." |
|
512 |
(declare (debug (form form))) |
|
513 |
`(apply 'append (--map ,form ,list))) |
|
514 |
|
|
515 |
(defun -mapcat (fn list) |
|
516 |
"Return the concatenation of the result of mapping FN over LIST. |
|
517 |
Thus function FN should return a list." |
|
518 |
(--mapcat (funcall fn it) list)) |
|
519 |
|
|
520 |
(defun -flatten (l) |
|
521 |
"Take a nested list L and return its contents as a single, flat list. |
|
522 |
|
|
523 |
Note that because `nil' represents a list of zero elements (an |
|
524 |
empty list), any mention of nil in L will disappear after |
|
525 |
flattening. If you need to preserve nils, consider `-flatten-n' |
|
526 |
or map them to some unique symbol and then map them back. |
|
527 |
|
|
528 |
Conses of two atoms are considered \"terminals\", that is, they |
|
529 |
aren't flattened further. |
|
530 |
|
|
531 |
See also: `-flatten-n'" |
|
532 |
(declare (pure t) (side-effect-free t)) |
|
533 |
(if (and (listp l) (listp (cdr l))) |
|
534 |
(-mapcat '-flatten l) |
|
535 |
(list l))) |
|
536 |
|
|
537 |
(defmacro --iterate (form init n) |
|
538 |
"Anaphoric version of `-iterate'." |
|
539 |
(declare (debug (form form form))) |
|
540 |
`(-iterate (lambda (it) ,form) ,init ,n)) |
|
541 |
|
|
542 |
(defun -flatten-n (num list) |
|
543 |
"Flatten NUM levels of a nested LIST. |
|
544 |
|
|
545 |
See also: `-flatten'" |
|
546 |
(declare (pure t) (side-effect-free t)) |
|
547 |
(-last-item (--iterate (--mapcat (-list it) it) list (1+ num)))) |
|
548 |
|
|
549 |
(defun -concat (&rest lists) |
|
550 |
"Return a new list with the concatenation of the elements in the supplied LISTS." |
|
551 |
(declare (pure t) (side-effect-free t)) |
|
552 |
(apply 'append lists)) |
|
553 |
|
|
554 |
(defalias '-copy 'copy-sequence |
|
555 |
"Create a shallow copy of LIST. |
|
556 |
|
|
557 |
\(fn LIST)") |
|
558 |
|
|
559 |
(defun -splice (pred fun list) |
|
560 |
"Splice lists generated by FUN in place of elements matching PRED in LIST. |
|
561 |
|
|
562 |
FUN takes the element matching PRED as input. |
|
563 |
|
|
564 |
This function can be used as replacement for `,@' in case you |
|
565 |
need to splice several lists at marked positions (for example |
|
566 |
with keywords). |
|
567 |
|
|
568 |
See also: `-splice-list', `-insert-at'" |
|
569 |
(let (r) |
|
570 |
(--each list |
|
571 |
(if (funcall pred it) |
|
572 |
(let ((new (funcall fun it))) |
|
573 |
(--each new (!cons it r))) |
|
574 |
(!cons it r))) |
|
575 |
(nreverse r))) |
|
576 |
|
|
577 |
(defmacro --splice (pred form list) |
|
578 |
"Anaphoric form of `-splice'." |
|
579 |
`(-splice (lambda (it) ,pred) (lambda (it) ,form) ,list)) |
|
580 |
|
|
581 |
(defun -splice-list (pred new-list list) |
|
582 |
"Splice NEW-LIST in place of elements matching PRED in LIST. |
|
583 |
|
|
584 |
See also: `-splice', `-insert-at'" |
|
585 |
(-splice pred (lambda (_) new-list) list)) |
|
586 |
|
|
587 |
(defmacro --splice-list (pred new-list list) |
|
588 |
"Anaphoric form of `-splice-list'." |
|
589 |
`(-splice-list (lambda (it) ,pred) ,new-list ,list)) |
|
590 |
|
|
591 |
(defun -cons* (&rest args) |
|
592 |
"Make a new list from the elements of ARGS. |
|
593 |
|
|
594 |
The last 2 members of ARGS are used as the final cons of the |
|
595 |
result so if the final member of ARGS is not a list the result is |
|
596 |
a dotted list." |
|
597 |
(declare (pure t) (side-effect-free t)) |
|
598 |
(-reduce-r 'cons args)) |
|
599 |
|
|
600 |
(defun -snoc (list elem &rest elements) |
|
601 |
"Append ELEM to the end of the list. |
|
602 |
|
|
603 |
This is like `cons', but operates on the end of list. |
|
604 |
|
|
605 |
If ELEMENTS is non nil, append these to the list as well." |
|
606 |
(-concat list (list elem) elements)) |
|
607 |
|
|
608 |
(defmacro --first (form list) |
|
609 |
"Anaphoric form of `-first'." |
|
610 |
(declare (debug (form form))) |
|
611 |
(let ((n (make-symbol "needle"))) |
|
612 |
`(let (,n) |
|
613 |
(--each-while ,list (not ,n) |
|
614 |
(when ,form (setq ,n it))) |
|
615 |
,n))) |
|
616 |
|
|
617 |
(defun -first (pred list) |
|
618 |
"Return the first x in LIST where (PRED x) is non-nil, else nil. |
|
619 |
|
|
620 |
To get the first item in the list no questions asked, use `car'. |
|
621 |
|
|
622 |
Alias: `-find'" |
|
623 |
(--first (funcall pred it) list)) |
|
624 |
|
|
625 |
(defalias '-find '-first) |
|
626 |
(defalias '--find '--first) |
|
627 |
|
|
628 |
(defmacro --some (form list) |
|
629 |
"Anaphoric form of `-some'." |
|
630 |
(declare (debug (form form))) |
|
631 |
(let ((n (make-symbol "needle"))) |
|
632 |
`(let (,n) |
|
633 |
(--each-while ,list (not ,n) |
|
634 |
(setq ,n ,form)) |
|
635 |
,n))) |
|
636 |
|
|
637 |
(defun -some (pred list) |
|
638 |
"Return (PRED x) for the first LIST item where (PRED x) is non-nil, else nil. |
|
639 |
|
|
640 |
Alias: `-any'" |
|
641 |
(--some (funcall pred it) list)) |
|
642 |
|
|
643 |
(defalias '-any '-some) |
|
644 |
(defalias '--any '--some) |
|
645 |
|
|
646 |
(defmacro --last (form list) |
|
647 |
"Anaphoric form of `-last'." |
|
648 |
(declare (debug (form form))) |
|
649 |
(let ((n (make-symbol "needle"))) |
|
650 |
`(let (,n) |
|
651 |
(--each ,list |
|
652 |
(when ,form (setq ,n it))) |
|
653 |
,n))) |
|
654 |
|
|
655 |
(defun -last (pred list) |
|
656 |
"Return the last x in LIST where (PRED x) is non-nil, else nil." |
|
657 |
(--last (funcall pred it) list)) |
|
658 |
|
|
659 |
(defalias '-first-item 'car |
|
660 |
"Return the first item of LIST, or nil on an empty list. |
|
661 |
|
|
662 |
See also: `-second-item', `-last-item'. |
|
663 |
|
|
664 |
\(fn LIST)") |
|
665 |
|
|
666 |
;; Ensure that calls to `-first-item' are compiled to a single opcode, |
|
667 |
;; just like `car'. |
|
668 |
(put '-first-item 'byte-opcode 'byte-car) |
|
669 |
(put '-first-item 'byte-compile 'byte-compile-one-arg) |
|
670 |
|
|
671 |
(defalias '-second-item 'cadr |
|
672 |
"Return the second item of LIST, or nil if LIST is too short. |
|
673 |
|
|
674 |
See also: `-third-item'. |
|
675 |
|
|
676 |
\(fn LIST)") |
|
677 |
|
|
678 |
(defalias '-third-item 'caddr |
|
679 |
"Return the third item of LIST, or nil if LIST is too short. |
|
680 |
|
|
681 |
See also: `-fourth-item'. |
|
682 |
|
|
683 |
\(fn LIST)") |
|
684 |
|
|
685 |
(defun -fourth-item (list) |
|
686 |
"Return the fourth item of LIST, or nil if LIST is too short. |
|
687 |
|
|
688 |
See also: `-fifth-item'." |
|
689 |
(declare (pure t) (side-effect-free t)) |
|
690 |
(car (cdr (cdr (cdr list))))) |
|
691 |
|
|
692 |
(defun -fifth-item (list) |
|
693 |
"Return the fifth item of LIST, or nil if LIST is too short. |
|
694 |
|
|
695 |
See also: `-last-item'." |
|
696 |
(declare (pure t) (side-effect-free t)) |
|
697 |
(car (cdr (cdr (cdr (cdr list)))))) |
|
698 |
|
|
699 |
;; TODO: gv was introduced in 24.3, so we can remove the if statement |
|
700 |
;; when support for earlier versions is dropped |
|
701 |
(eval-when-compile |
|
702 |
(require 'cl) |
|
703 |
(if (fboundp 'gv-define-simple-setter) |
|
704 |
(gv-define-simple-setter -first-item setcar) |
|
705 |
(require 'cl) |
|
706 |
(with-no-warnings |
|
707 |
(defsetf -first-item (x) (val) `(setcar ,x ,val))))) |
|
708 |
|
|
709 |
(defun -last-item (list) |
|
710 |
"Return the last item of LIST, or nil on an empty list." |
|
711 |
(declare (pure t) (side-effect-free t)) |
|
712 |
(car (last list))) |
|
713 |
|
|
714 |
;; TODO: gv was introduced in 24.3, so we can remove the if statement |
|
715 |
;; when support for earlier versions is dropped |
|
716 |
(eval-when-compile |
|
717 |
(if (fboundp 'gv-define-setter) |
|
718 |
(gv-define-setter -last-item (val x) `(setcar (last ,x) ,val)) |
|
719 |
(with-no-warnings |
|
720 |
(defsetf -last-item (x) (val) `(setcar (last ,x) ,val))))) |
|
721 |
|
|
722 |
(defun -butlast (list) |
|
723 |
"Return a list of all items in list except for the last." |
|
724 |
;; no alias as we don't want magic optional argument |
|
725 |
(declare (pure t) (side-effect-free t)) |
|
726 |
(butlast list)) |
|
727 |
|
|
728 |
(defmacro --count (pred list) |
|
729 |
"Anaphoric form of `-count'." |
|
730 |
(declare (debug (form form))) |
|
731 |
(let ((r (make-symbol "result"))) |
|
732 |
`(let ((,r 0)) |
|
733 |
(--each ,list (when ,pred (setq ,r (1+ ,r)))) |
|
734 |
,r))) |
|
735 |
|
|
736 |
(defun -count (pred list) |
|
737 |
"Counts the number of items in LIST where (PRED item) is non-nil." |
|
738 |
(--count (funcall pred it) list)) |
|
739 |
|
|
740 |
(defun ---truthy? (val) |
|
741 |
(declare (pure t) (side-effect-free t)) |
|
742 |
(not (null val))) |
|
743 |
|
|
744 |
(defmacro --any? (form list) |
|
745 |
"Anaphoric form of `-any?'." |
|
746 |
(declare (debug (form form))) |
|
747 |
`(---truthy? (--some ,form ,list))) |
|
748 |
|
|
749 |
(defun -any? (pred list) |
|
750 |
"Return t if (PRED x) is non-nil for any x in LIST, else nil. |
|
751 |
|
|
752 |
Alias: `-any-p', `-some?', `-some-p'" |
|
753 |
(--any? (funcall pred it) list)) |
|
754 |
|
|
755 |
(defalias '-some? '-any?) |
|
756 |
(defalias '--some? '--any?) |
|
757 |
(defalias '-any-p '-any?) |
|
758 |
(defalias '--any-p '--any?) |
|
759 |
(defalias '-some-p '-any?) |
|
760 |
(defalias '--some-p '--any?) |
|
761 |
|
|
762 |
(defmacro --all? (form list) |
|
763 |
"Anaphoric form of `-all?'." |
|
764 |
(declare (debug (form form))) |
|
765 |
(let ((a (make-symbol "all"))) |
|
766 |
`(let ((,a t)) |
|
767 |
(--each-while ,list ,a (setq ,a ,form)) |
|
768 |
(---truthy? ,a)))) |
|
769 |
|
|
770 |
(defun -all? (pred list) |
|
771 |
"Return t if (PRED x) is non-nil for all x in LIST, else nil. |
|
772 |
|
|
773 |
Alias: `-all-p', `-every?', `-every-p'" |
|
774 |
(--all? (funcall pred it) list)) |
|
775 |
|
|
776 |
(defalias '-every? '-all?) |
|
777 |
(defalias '--every? '--all?) |
|
778 |
(defalias '-all-p '-all?) |
|
779 |
(defalias '--all-p '--all?) |
|
780 |
(defalias '-every-p '-all?) |
|
781 |
(defalias '--every-p '--all?) |
|
782 |
|
|
783 |
(defmacro --none? (form list) |
|
784 |
"Anaphoric form of `-none?'." |
|
785 |
(declare (debug (form form))) |
|
786 |
`(--all? (not ,form) ,list)) |
|
787 |
|
|
788 |
(defun -none? (pred list) |
|
789 |
"Return t if (PRED x) is nil for all x in LIST, else nil. |
|
790 |
|
|
791 |
Alias: `-none-p'" |
|
792 |
(--none? (funcall pred it) list)) |
|
793 |
|
|
794 |
(defalias '-none-p '-none?) |
|
795 |
(defalias '--none-p '--none?) |
|
796 |
|
|
797 |
(defmacro --only-some? (form list) |
|
798 |
"Anaphoric form of `-only-some?'." |
|
799 |
(declare (debug (form form))) |
|
800 |
(let ((y (make-symbol "yes")) |
|
801 |
(n (make-symbol "no"))) |
|
802 |
`(let (,y ,n) |
|
803 |
(--each-while ,list (not (and ,y ,n)) |
|
804 |
(if ,form (setq ,y t) (setq ,n t))) |
|
805 |
(---truthy? (and ,y ,n))))) |
|
806 |
|
|
807 |
(defun -only-some? (pred list) |
|
808 |
"Return `t` if at least one item of LIST matches PRED and at least one item of LIST does not match PRED. |
|
809 |
Return `nil` both if all items match the predicate or if none of the items match the predicate. |
|
810 |
|
|
811 |
Alias: `-only-some-p'" |
|
812 |
(--only-some? (funcall pred it) list)) |
|
813 |
|
|
814 |
(defalias '-only-some-p '-only-some?) |
|
815 |
(defalias '--only-some-p '--only-some?) |
|
816 |
|
|
817 |
(defun -slice (list from &optional to step) |
|
818 |
"Return copy of LIST, starting from index FROM to index TO. |
|
819 |
|
|
820 |
FROM or TO may be negative. These values are then interpreted |
|
821 |
modulo the length of the list. |
|
822 |
|
|
823 |
If STEP is a number, only each STEPth item in the resulting |
|
824 |
section is returned. Defaults to 1." |
|
825 |
(declare (pure t) (side-effect-free t)) |
|
826 |
(let ((length (length list)) |
|
827 |
(new-list nil)) |
|
828 |
;; to defaults to the end of the list |
|
829 |
(setq to (or to length)) |
|
830 |
(setq step (or step 1)) |
|
831 |
;; handle negative indices |
|
832 |
(when (< from 0) |
|
833 |
(setq from (mod from length))) |
|
834 |
(when (< to 0) |
|
835 |
(setq to (mod to length))) |
|
836 |
|
|
837 |
;; iterate through the list, keeping the elements we want |
|
838 |
(--each-while list (< it-index to) |
|
839 |
(when (and (>= it-index from) |
|
840 |
(= (mod (- from it-index) step) 0)) |
|
841 |
(push it new-list))) |
|
842 |
(nreverse new-list))) |
|
843 |
|
|
844 |
(defun -take (n list) |
|
845 |
"Return a new list of the first N items in LIST, or all items if there are fewer than N. |
|
846 |
|
|
847 |
See also: `-take-last'" |
|
848 |
(declare (pure t) (side-effect-free t)) |
|
849 |
(let (result) |
|
850 |
(--dotimes n |
|
851 |
(when list |
|
852 |
(!cons (car list) result) |
|
853 |
(!cdr list))) |
|
854 |
(nreverse result))) |
|
855 |
|
|
856 |
(defun -take-last (n list) |
|
857 |
"Return the last N items of LIST in order. |
|
858 |
|
|
859 |
See also: `-take'" |
|
860 |
(declare (pure t) (side-effect-free t)) |
|
861 |
(copy-sequence (last list n))) |
|
862 |
|
|
863 |
(defalias '-drop 'nthcdr |
|
864 |
"Return the tail of LIST without the first N items. |
|
865 |
|
|
866 |
See also: `-drop-last' |
|
867 |
|
|
868 |
\(fn N LIST)") |
|
869 |
|
|
870 |
(defun -drop-last (n list) |
|
871 |
"Remove the last N items of LIST and return a copy. |
|
872 |
|
|
873 |
See also: `-drop'" |
|
874 |
;; No alias because we don't want magic optional argument |
|
875 |
(declare (pure t) (side-effect-free t)) |
|
876 |
(butlast list n)) |
|
877 |
|
|
878 |
(defmacro --take-while (form list) |
|
879 |
"Anaphoric form of `-take-while'." |
|
880 |
(declare (debug (form form))) |
|
881 |
(let ((r (make-symbol "result"))) |
|
882 |
`(let (,r) |
|
883 |
(--each-while ,list ,form (!cons it ,r)) |
|
884 |
(nreverse ,r)))) |
|
885 |
|
|
886 |
(defun -take-while (pred list) |
|
887 |
"Return a new list of successive items from LIST while (PRED item) returns a non-nil value." |
|
888 |
(--take-while (funcall pred it) list)) |
|
889 |
|
|
890 |
(defmacro --drop-while (form list) |
|
891 |
"Anaphoric form of `-drop-while'." |
|
892 |
(declare (debug (form form))) |
|
893 |
(let ((l (make-symbol "list"))) |
|
894 |
`(let ((,l ,list)) |
|
895 |
(while (and ,l (let ((it (car ,l))) ,form)) |
|
896 |
(!cdr ,l)) |
|
897 |
,l))) |
|
898 |
|
|
899 |
(defun -drop-while (pred list) |
|
900 |
"Return the tail of LIST starting from the first item for which (PRED item) returns nil." |
|
901 |
(--drop-while (funcall pred it) list)) |
|
902 |
|
|
903 |
(defun -split-at (n list) |
|
904 |
"Return a list of ((-take N LIST) (-drop N LIST)), in no more than one pass through the list." |
|
905 |
(declare (pure t) (side-effect-free t)) |
|
906 |
(let (result) |
|
907 |
(--dotimes n |
|
908 |
(when list |
|
909 |
(!cons (car list) result) |
|
910 |
(!cdr list))) |
|
911 |
(list (nreverse result) list))) |
|
912 |
|
|
913 |
(defun -rotate (n list) |
|
914 |
"Rotate LIST N places to the right. With N negative, rotate to the left. |
|
915 |
The time complexity is O(n)." |
|
916 |
(declare (pure t) (side-effect-free t)) |
|
917 |
(if (> n 0) |
|
918 |
(append (last list n) (butlast list n)) |
|
919 |
(append (-drop (- n) list) (-take (- n) list)))) |
|
920 |
|
|
921 |
(defun -insert-at (n x list) |
|
922 |
"Return a list with X inserted into LIST at position N. |
|
923 |
|
|
924 |
See also: `-splice', `-splice-list'" |
|
925 |
(declare (pure t) (side-effect-free t)) |
|
926 |
(let ((split-list (-split-at n list))) |
|
927 |
(nconc (car split-list) (cons x (cadr split-list))))) |
|
928 |
|
|
929 |
(defun -replace-at (n x list) |
|
930 |
"Return a list with element at Nth position in LIST replaced with X. |
|
931 |
|
|
932 |
See also: `-replace'" |
|
933 |
(declare (pure t) (side-effect-free t)) |
|
934 |
(let ((split-list (-split-at n list))) |
|
935 |
(nconc (car split-list) (cons x (cdr (cadr split-list)))))) |
|
936 |
|
|
937 |
(defun -update-at (n func list) |
|
938 |
"Return a list with element at Nth position in LIST replaced with `(func (nth n list))`. |
|
939 |
|
|
940 |
See also: `-map-when'" |
|
941 |
(let ((split-list (-split-at n list))) |
|
942 |
(nconc (car split-list) (cons (funcall func (car (cadr split-list))) (cdr (cadr split-list)))))) |
|
943 |
|
|
944 |
(defmacro --update-at (n form list) |
|
945 |
"Anaphoric version of `-update-at'." |
|
946 |
(declare (debug (form form form))) |
|
947 |
`(-update-at ,n (lambda (it) ,form) ,list)) |
|
948 |
|
|
949 |
(defun -remove-at (n list) |
|
950 |
"Return a list with element at Nth position in LIST removed. |
|
951 |
|
|
952 |
See also: `-remove-at-indices', `-remove'" |
|
953 |
(declare (pure t) (side-effect-free t)) |
|
954 |
(-remove-at-indices (list n) list)) |
|
955 |
|
|
956 |
(defun -remove-at-indices (indices list) |
|
957 |
"Return a list whose elements are elements from LIST without |
|
958 |
elements selected as `(nth i list)` for all i |
|
959 |
from INDICES. |
|
960 |
|
|
961 |
See also: `-remove-at', `-remove'" |
|
962 |
(declare (pure t) (side-effect-free t)) |
|
963 |
(let* ((indices (-sort '< indices)) |
|
964 |
(diffs (cons (car indices) (-map '1- (-zip-with '- (cdr indices) indices)))) |
|
965 |
r) |
|
966 |
(--each diffs |
|
967 |
(let ((split (-split-at it list))) |
|
968 |
(!cons (car split) r) |
|
969 |
(setq list (cdr (cadr split))))) |
|
970 |
(!cons list r) |
|
971 |
(apply '-concat (nreverse r)))) |
|
972 |
|
|
973 |
(defmacro --split-with (pred list) |
|
974 |
"Anaphoric form of `-split-with'." |
|
975 |
(declare (debug (form form))) |
|
976 |
(let ((l (make-symbol "list")) |
|
977 |
(r (make-symbol "result")) |
|
978 |
(c (make-symbol "continue"))) |
|
979 |
`(let ((,l ,list) |
|
980 |
(,r nil) |
|
981 |
(,c t)) |
|
982 |
(while (and ,l ,c) |
|
983 |
(let ((it (car ,l))) |
|
984 |
(if (not ,pred) |
|
985 |
(setq ,c nil) |
|
986 |
(!cons it ,r) |
|
987 |
(!cdr ,l)))) |
|
988 |
(list (nreverse ,r) ,l)))) |
|
989 |
|
|
990 |
(defun -split-with (pred list) |
|
991 |
"Return a list of ((-take-while PRED LIST) (-drop-while PRED LIST)), in no more than one pass through the list." |
|
992 |
(--split-with (funcall pred it) list)) |
|
993 |
|
|
994 |
(defmacro -split-on (item list) |
|
995 |
"Split the LIST each time ITEM is found. |
|
996 |
|
|
997 |
Unlike `-partition-by', the ITEM is discarded from the results. |
|
998 |
Empty lists are also removed from the result. |
|
999 |
|
|
1000 |
Comparison is done by `equal'. |
|
1001 |
|
|
1002 |
See also `-split-when'" |
|
1003 |
(declare (debug (form form))) |
|
1004 |
`(-split-when (lambda (it) (equal it ,item)) ,list)) |
|
1005 |
|
|
1006 |
(defmacro --split-when (form list) |
|
1007 |
"Anaphoric version of `-split-when'." |
|
1008 |
(declare (debug (form form))) |
|
1009 |
`(-split-when (lambda (it) ,form) ,list)) |
|
1010 |
|
|
1011 |
(defun -split-when (fn list) |
|
1012 |
"Split the LIST on each element where FN returns non-nil. |
|
1013 |
|
|
1014 |
Unlike `-partition-by', the \"matched\" element is discarded from |
|
1015 |
the results. Empty lists are also removed from the result. |
|
1016 |
|
|
1017 |
This function can be thought of as a generalization of |
|
1018 |
`split-string'." |
|
1019 |
(let (r s) |
|
1020 |
(while list |
|
1021 |
(if (not (funcall fn (car list))) |
|
1022 |
(push (car list) s) |
|
1023 |
(when s (push (nreverse s) r)) |
|
1024 |
(setq s nil)) |
|
1025 |
(!cdr list)) |
|
1026 |
(when s (push (nreverse s) r)) |
|
1027 |
(nreverse r))) |
|
1028 |
|
|
1029 |
(defmacro --separate (form list) |
|
1030 |
"Anaphoric form of `-separate'." |
|
1031 |
(declare (debug (form form))) |
|
1032 |
(let ((y (make-symbol "yes")) |
|
1033 |
(n (make-symbol "no"))) |
|
1034 |
`(let (,y ,n) |
|
1035 |
(--each ,list (if ,form (!cons it ,y) (!cons it ,n))) |
|
1036 |
(list (nreverse ,y) (nreverse ,n))))) |
|
1037 |
|
|
1038 |
(defun -separate (pred list) |
|
1039 |
"Return a list of ((-filter PRED LIST) (-remove PRED LIST)), in one pass through the list." |
|
1040 |
(--separate (funcall pred it) list)) |
|
1041 |
|
|
1042 |
(defun ---partition-all-in-steps-reversed (n step list) |
|
1043 |
"Private: Used by -partition-all-in-steps and -partition-in-steps." |
|
1044 |
(when (< step 1) |
|
1045 |
(error "Step must be a positive number, or you're looking at some juicy infinite loops.")) |
|
1046 |
(let ((result nil)) |
|
1047 |
(while list |
|
1048 |
(!cons (-take n list) result) |
|
1049 |
(setq list (-drop step list))) |
|
1050 |
result)) |
|
1051 |
|
|
1052 |
(defun -partition-all-in-steps (n step list) |
|
1053 |
"Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart. |
|
1054 |
The last groups may contain less than N items." |
|
1055 |
(declare (pure t) (side-effect-free t)) |
|
1056 |
(nreverse (---partition-all-in-steps-reversed n step list))) |
|
1057 |
|
|
1058 |
(defun -partition-in-steps (n step list) |
|
1059 |
"Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart. |
|
1060 |
If there are not enough items to make the last group N-sized, |
|
1061 |
those items are discarded." |
|
1062 |
(declare (pure t) (side-effect-free t)) |
|
1063 |
(let ((result (---partition-all-in-steps-reversed n step list))) |
|
1064 |
(while (and result (< (length (car result)) n)) |
|
1065 |
(!cdr result)) |
|
1066 |
(nreverse result))) |
|
1067 |
|
|
1068 |
(defun -partition-all (n list) |
|
1069 |
"Return a new list with the items in LIST grouped into N-sized sublists. |
|
1070 |
The last group may contain less than N items." |
|
1071 |
(declare (pure t) (side-effect-free t)) |
|
1072 |
(-partition-all-in-steps n n list)) |
|
1073 |
|
|
1074 |
(defun -partition (n list) |
|
1075 |
"Return a new list with the items in LIST grouped into N-sized sublists. |
|
1076 |
If there are not enough items to make the last group N-sized, |
|
1077 |
those items are discarded." |
|
1078 |
(declare (pure t) (side-effect-free t)) |
|
1079 |
(-partition-in-steps n n list)) |
|
1080 |
|
|
1081 |
(defmacro --partition-by (form list) |
|
1082 |
"Anaphoric form of `-partition-by'." |
|
1083 |
(declare (debug (form form))) |
|
1084 |
(let ((r (make-symbol "result")) |
|
1085 |
(s (make-symbol "sublist")) |
|
1086 |
(v (make-symbol "value")) |
|
1087 |
(n (make-symbol "new-value")) |
|
1088 |
(l (make-symbol "list"))) |
|
1089 |
`(let ((,l ,list)) |
|
1090 |
(when ,l |
|
1091 |
(let* ((,r nil) |
|
1092 |
(it (car ,l)) |
|
1093 |
(,s (list it)) |
|
1094 |
(,v ,form) |
|
1095 |
(,l (cdr ,l))) |
|
1096 |
(while ,l |
|
1097 |
(let* ((it (car ,l)) |
|
1098 |
(,n ,form)) |
|
1099 |
(unless (equal ,v ,n) |
|
1100 |
(!cons (nreverse ,s) ,r) |
|
1101 |
(setq ,s nil) |
|
1102 |
(setq ,v ,n)) |
|
1103 |
(!cons it ,s) |
|
1104 |
(!cdr ,l))) |
|
1105 |
(!cons (nreverse ,s) ,r) |
|
1106 |
(nreverse ,r)))))) |
|
1107 |
|
|
1108 |
(defun -partition-by (fn list) |
|
1109 |
"Apply FN to each item in LIST, splitting it each time FN returns a new value." |
|
1110 |
(--partition-by (funcall fn it) list)) |
|
1111 |
|
|
1112 |
(defmacro --partition-by-header (form list) |
|
1113 |
"Anaphoric form of `-partition-by-header'." |
|
1114 |
(declare (debug (form form))) |
|
1115 |
(let ((r (make-symbol "result")) |
|
1116 |
(s (make-symbol "sublist")) |
|
1117 |
(h (make-symbol "header-value")) |
|
1118 |
(b (make-symbol "seen-body?")) |
|
1119 |
(n (make-symbol "new-value")) |
|
1120 |
(l (make-symbol "list"))) |
|
1121 |
`(let ((,l ,list)) |
|
1122 |
(when ,l |
|
1123 |
(let* ((,r nil) |
|
1124 |
(it (car ,l)) |
|
1125 |
(,s (list it)) |
|
1126 |
(,h ,form) |
|
1127 |
(,b nil) |
|
1128 |
(,l (cdr ,l))) |
|
1129 |
(while ,l |
|
1130 |
(let* ((it (car ,l)) |
|
1131 |
(,n ,form)) |
|
1132 |
(if (equal ,h ,n) |
|
1133 |
(when ,b |
|
1134 |
(!cons (nreverse ,s) ,r) |
|
1135 |
(setq ,s nil) |
|
1136 |
(setq ,b nil)) |
|
1137 |
(setq ,b t)) |
|
1138 |
(!cons it ,s) |
|
1139 |
(!cdr ,l))) |
|
1140 |
(!cons (nreverse ,s) ,r) |
|
1141 |
(nreverse ,r)))))) |
|
1142 |
|
|
1143 |
(defun -partition-by-header (fn list) |
|
1144 |
"Apply FN to the first item in LIST. That is the header |
|
1145 |
value. Apply FN to each item in LIST, splitting it each time FN |
|
1146 |
returns the header value, but only after seeing at least one |
|
1147 |
other value (the body)." |
|
1148 |
(--partition-by-header (funcall fn it) list)) |
|
1149 |
|
|
1150 |
(defun -partition-after-pred (pred list) |
|
1151 |
"Partition directly after each time PRED is true on an element of LIST." |
|
1152 |
(when list |
|
1153 |
(let ((rest (-partition-after-pred pred |
|
1154 |
(cdr list)))) |
|
1155 |
(if (funcall pred (car list)) |
|
1156 |
;;split after (car list) |
|
1157 |
(cons (list (car list)) |
|
1158 |
rest) |
|
1159 |
|
|
1160 |
;;don't split after (car list) |
|
1161 |
(cons (cons (car list) |
|
1162 |
(car rest)) |
|
1163 |
(cdr rest)))))) |
|
1164 |
|
|
1165 |
(defun -partition-before-pred (pred list) |
|
1166 |
"Partition directly before each time PRED is true on an element of LIST." |
|
1167 |
(nreverse (-map #'reverse |
|
1168 |
(-partition-after-pred pred (reverse list))))) |
|
1169 |
|
|
1170 |
(defun -partition-after-item (item list) |
|
1171 |
"Partition directly after each time ITEM appears in LIST." |
|
1172 |
(-partition-after-pred (lambda (ele) (equal ele item)) |
|
1173 |
list)) |
|
1174 |
|
|
1175 |
(defun -partition-before-item (item list) |
|
1176 |
"Partition directly before each time ITEM appears in LIST." |
|
1177 |
(-partition-before-pred (lambda (ele) (equal ele item)) |
|
1178 |
list)) |
|
1179 |
|
|
1180 |
(defmacro --group-by (form list) |
|
1181 |
"Anaphoric form of `-group-by'." |
|
1182 |
(declare (debug t)) |
|
1183 |
(let ((n (make-symbol "n")) |
|
1184 |
(k (make-symbol "k")) |
|
1185 |
(grp (make-symbol "grp"))) |
|
1186 |
`(nreverse |
|
1187 |
(-map |
|
1188 |
(lambda (,n) |
|
1189 |
(cons (car ,n) |
|
1190 |
(nreverse (cdr ,n)))) |
|
1191 |
(--reduce-from |
|
1192 |
(let* ((,k (,@form)) |
|
1193 |
(,grp (assoc ,k acc))) |
|
1194 |
(if ,grp |
|
1195 |
(setcdr ,grp (cons it (cdr ,grp))) |
|
1196 |
(push |
|
1197 |
(list ,k it) |
|
1198 |
acc)) |
|
1199 |
acc) |
|
1200 |
nil ,list))))) |
|
1201 |
|
|
1202 |
(defun -group-by (fn list) |
|
1203 |
"Separate LIST into an alist whose keys are FN applied to the |
|
1204 |
elements of LIST. Keys are compared by `equal'." |
|
1205 |
(--group-by (funcall fn it) list)) |
|
1206 |
|
|
1207 |
(defun -interpose (sep list) |
|
1208 |
"Return a new list of all elements in LIST separated by SEP." |
|
1209 |
(declare (pure t) (side-effect-free t)) |
|
1210 |
(let (result) |
|
1211 |
(when list |
|
1212 |
(!cons (car list) result) |
|
1213 |
(!cdr list)) |
|
1214 |
(while list |
|
1215 |
(setq result (cons (car list) (cons sep result))) |
|
1216 |
(!cdr list)) |
|
1217 |
(nreverse result))) |
|
1218 |
|
|
1219 |
(defun -interleave (&rest lists) |
|
1220 |
"Return a new list of the first item in each list, then the second etc." |
|
1221 |
(declare (pure t) (side-effect-free t)) |
|
1222 |
(when lists |
|
1223 |
(let (result) |
|
1224 |
(while (-none? 'null lists) |
|
1225 |
(--each lists (!cons (car it) result)) |
|
1226 |
(setq lists (-map 'cdr lists))) |
|
1227 |
(nreverse result)))) |
|
1228 |
|
|
1229 |
(defmacro --zip-with (form list1 list2) |
|
1230 |
"Anaphoric form of `-zip-with'. |
|
1231 |
|
|
1232 |
The elements in list1 are bound as symbol `it', the elements in list2 as symbol `other'." |
|
1233 |
(declare (debug (form form form))) |
|
1234 |
(let ((r (make-symbol "result")) |
|
1235 |
(l1 (make-symbol "list1")) |
|
1236 |
(l2 (make-symbol "list2"))) |
|
1237 |
`(let ((,r nil) |
|
1238 |
(,l1 ,list1) |
|
1239 |
(,l2 ,list2)) |
|
1240 |
(while (and ,l1 ,l2) |
|
1241 |
(let ((it (car ,l1)) |
|
1242 |
(other (car ,l2))) |
|
1243 |
(!cons ,form ,r) |
|
1244 |
(!cdr ,l1) |
|
1245 |
(!cdr ,l2))) |
|
1246 |
(nreverse ,r)))) |
|
1247 |
|
|
1248 |
(defun -zip-with (fn list1 list2) |
|
1249 |
"Zip the two lists LIST1 and LIST2 using a function FN. This |
|
1250 |
function is applied pairwise taking as first argument element of |
|
1251 |
LIST1 and as second argument element of LIST2 at corresponding |
|
1252 |
position. |
|
1253 |
|
|
1254 |
The anaphoric form `--zip-with' binds the elements from LIST1 as symbol `it', |
|
1255 |
and the elements from LIST2 as symbol `other'." |
|
1256 |
(--zip-with (funcall fn it other) list1 list2)) |
|
1257 |
|
|
1258 |
(defun -zip (&rest lists) |
|
1259 |
"Zip LISTS together. Group the head of each list, followed by the |
|
1260 |
second elements of each list, and so on. The lengths of the returned |
|
1261 |
groupings are equal to the length of the shortest input list. |
|
1262 |
|
|
1263 |
If two lists are provided as arguments, return the groupings as a list |
|
1264 |
of cons cells. Otherwise, return the groupings as a list of lists. |
|
1265 |
|
|
1266 |
Please note! This distinction is being removed in an upcoming 3.0 |
|
1267 |
release of Dash. If you rely on this behavior, use -zip-pair instead." |
|
1268 |
(declare (pure t) (side-effect-free t)) |
|
1269 |
(when lists |
|
1270 |
(let (results) |
|
1271 |
(while (-none? 'null lists) |
|
1272 |
(setq results (cons (mapcar 'car lists) results)) |
|
1273 |
(setq lists (mapcar 'cdr lists))) |
|
1274 |
(setq results (nreverse results)) |
|
1275 |
(if (= (length lists) 2) |
|
1276 |
;; to support backward compatability, return |
|
1277 |
;; a cons cell if two lists were provided |
|
1278 |
(--map (cons (car it) (cadr it)) results) |
|
1279 |
results)))) |
|
1280 |
|
|
1281 |
(defalias '-zip-pair '-zip) |
|
1282 |
|
|
1283 |
(defun -zip-fill (fill-value &rest lists) |
|
1284 |
"Zip LISTS, with FILL-VALUE padded onto the shorter lists. The |
|
1285 |
lengths of the returned groupings are equal to the length of the |
|
1286 |
longest input list." |
|
1287 |
(declare (pure t) (side-effect-free t)) |
|
1288 |
(apply '-zip (apply '-pad (cons fill-value lists)))) |
|
1289 |
|
|
1290 |
(defun -unzip (lists) |
|
1291 |
"Unzip LISTS. |
|
1292 |
|
|
1293 |
This works just like `-zip' but takes a list of lists instead of |
|
1294 |
a variable number of arguments, such that |
|
1295 |
|
|
1296 |
(-unzip (-zip L1 L2 L3 ...)) |
|
1297 |
|
|
1298 |
is identity (given that the lists are the same length). |
|
1299 |
|
|
1300 |
See also: `-zip'" |
|
1301 |
(apply '-zip lists)) |
|
1302 |
|
|
1303 |
(defun -cycle (list) |
|
1304 |
"Return an infinite copy of LIST that will cycle through the |
|
1305 |
elements and repeat from the beginning." |
|
1306 |
(declare (pure t) (side-effect-free t)) |
|
1307 |
(let ((newlist (-map 'identity list))) |
|
1308 |
(nconc newlist newlist))) |
|
1309 |
|
|
1310 |
(defun -pad (fill-value &rest lists) |
|
1311 |
"Appends FILL-VALUE to the end of each list in LISTS such that they |
|
1312 |
will all have the same length." |
|
1313 |
(let* ((annotations (-annotate 'length lists)) |
|
1314 |
(n (-max (-map 'car annotations)))) |
|
1315 |
(--map (append (cdr it) (-repeat (- n (car it)) fill-value)) annotations))) |
|
1316 |
|
|
1317 |
(defun -annotate (fn list) |
|
1318 |
"Return a list of cons cells where each cell is FN applied to each |
|
1319 |
element of LIST paired with the unmodified element of LIST." |
|
1320 |
(-zip (-map fn list) list)) |
|
1321 |
|
|
1322 |
(defmacro --annotate (form list) |
|
1323 |
"Anaphoric version of `-annotate'." |
|
1324 |
(declare (debug (form form))) |
|
1325 |
`(-annotate (lambda (it) ,form) ,list)) |
|
1326 |
|
|
1327 |
(defun dash--table-carry (lists restore-lists &optional re) |
|
1328 |
"Helper for `-table' and `-table-flat'. |
|
1329 |
|
|
1330 |
If a list overflows, carry to the right and reset the list." |
|
1331 |
(while (not (or (car lists) |
|
1332 |
(equal lists '(nil)))) |
|
1333 |
(setcar lists (car restore-lists)) |
|
1334 |
(pop (cadr lists)) |
|
1335 |
(!cdr lists) |
|
1336 |
(!cdr restore-lists) |
|
1337 |
(when re |
|
1338 |
(push (nreverse (car re)) (cadr re)) |
|
1339 |
(setcar re nil) |
|
1340 |
(!cdr re)))) |
|
1341 |
|
|
1342 |
(defun -table (fn &rest lists) |
|
1343 |
"Compute outer product of LISTS using function FN. |
|
1344 |
|
|
1345 |
The function FN should have the same arity as the number of |
|
1346 |
supplied lists. |
|
1347 |
|
|
1348 |
The outer product is computed by applying fn to all possible |
|
1349 |
combinations created by taking one element from each list in |
|
1350 |
order. The dimension of the result is (length lists). |
|
1351 |
|
|
1352 |
See also: `-table-flat'" |
|
1353 |
(let ((restore-lists (copy-sequence lists)) |
|
1354 |
(last-list (last lists)) |
|
1355 |
(re (make-list (length lists) nil))) |
|
1356 |
(while (car last-list) |
|
1357 |
(let ((item (apply fn (-map 'car lists)))) |
|
1358 |
(push item (car re)) |
|
1359 |
(setcar lists (cdar lists)) ;; silence byte compiler |
|
1360 |
(dash--table-carry lists restore-lists re))) |
|
1361 |
(nreverse (car (last re))))) |
|
1362 |
|
|
1363 |
(defun -table-flat (fn &rest lists) |
|
1364 |
"Compute flat outer product of LISTS using function FN. |
|
1365 |
|
|
1366 |
The function FN should have the same arity as the number of |
|
1367 |
supplied lists. |
|
1368 |
|
|
1369 |
The outer product is computed by applying fn to all possible |
|
1370 |
combinations created by taking one element from each list in |
|
1371 |
order. The results are flattened, ignoring the tensor structure |
|
1372 |
of the result. This is equivalent to calling: |
|
1373 |
|
|
1374 |
(-flatten-n (1- (length lists)) (apply \\='-table fn lists)) |
|
1375 |
|
|
1376 |
but the implementation here is much more efficient. |
|
1377 |
|
|
1378 |
See also: `-flatten-n', `-table'" |
|
1379 |
(let ((restore-lists (copy-sequence lists)) |
|
1380 |
(last-list (last lists)) |
|
1381 |
re) |
|
1382 |
(while (car last-list) |
|
1383 |
(let ((item (apply fn (-map 'car lists)))) |
|
1384 |
(push item re) |
|
1385 |
(setcar lists (cdar lists)) ;; silence byte compiler |
|
1386 |
(dash--table-carry lists restore-lists))) |
|
1387 |
(nreverse re))) |
|
1388 |
|
|
1389 |
(defun -partial (fn &rest args) |
|
1390 |
"Take a function FN and fewer than the normal arguments to FN, |
|
1391 |
and return a fn that takes a variable number of additional ARGS. |
|
1392 |
When called, the returned function calls FN with ARGS first and |
|
1393 |
then additional args." |
|
1394 |
(apply 'apply-partially fn args)) |
|
1395 |
|
|
1396 |
(defun -elem-index (elem list) |
|
1397 |
"Return the index of the first element in the given LIST which |
|
1398 |
is equal to the query element ELEM, or nil if there is no |
|
1399 |
such element." |
|
1400 |
(declare (pure t) (side-effect-free t)) |
|
1401 |
(car (-elem-indices elem list))) |
|
1402 |
|
|
1403 |
(defun -elem-indices (elem list) |
|
1404 |
"Return the indices of all elements in LIST equal to the query |
|
1405 |
element ELEM, in ascending order." |
|
1406 |
(declare (pure t) (side-effect-free t)) |
|
1407 |
(-find-indices (-partial 'equal elem) list)) |
|
1408 |
|
|
1409 |
(defun -find-indices (pred list) |
|
1410 |
"Return the indices of all elements in LIST satisfying the |
|
1411 |
predicate PRED, in ascending order." |
|
1412 |
(apply 'append (--map-indexed (when (funcall pred it) (list it-index)) list))) |
|
1413 |
|
|
1414 |
(defmacro --find-indices (form list) |
|
1415 |
"Anaphoric version of `-find-indices'." |
|
1416 |
(declare (debug (form form))) |
|
1417 |
`(-find-indices (lambda (it) ,form) ,list)) |
|
1418 |
|
|
1419 |
(defun -find-index (pred list) |
|
1420 |
"Take a predicate PRED and a LIST and return the index of the |
|
1421 |
first element in the list satisfying the predicate, or nil if |
|
1422 |
there is no such element. |
|
1423 |
|
|
1424 |
See also `-first'." |
|
1425 |
(car (-find-indices pred list))) |
|
1426 |
|
|
1427 |
(defmacro --find-index (form list) |
|
1428 |
"Anaphoric version of `-find-index'." |
|
1429 |
(declare (debug (form form))) |
|
1430 |
`(-find-index (lambda (it) ,form) ,list)) |
|
1431 |
|
|
1432 |
(defun -find-last-index (pred list) |
|
1433 |
"Take a predicate PRED and a LIST and return the index of the |
|
1434 |
last element in the list satisfying the predicate, or nil if |
|
1435 |
there is no such element. |
|
1436 |
|
|
1437 |
See also `-last'." |
|
1438 |
(-last-item (-find-indices pred list))) |
|
1439 |
|
|
1440 |
(defmacro --find-last-index (form list) |
|
1441 |
"Anaphoric version of `-find-last-index'." |
|
1442 |
`(-find-last-index (lambda (it) ,form) ,list)) |
|
1443 |
|
|
1444 |
(defun -select-by-indices (indices list) |
|
1445 |
"Return a list whose elements are elements from LIST selected |
|
1446 |
as `(nth i list)` for all i from INDICES." |
|
1447 |
(declare (pure t) (side-effect-free t)) |
|
1448 |
(let (r) |
|
1449 |
(--each indices |
|
1450 |
(!cons (nth it list) r)) |
|
1451 |
(nreverse r))) |
|
1452 |
|
|
1453 |
(defun -select-columns (columns table) |
|
1454 |
"Select COLUMNS from TABLE. |
|
1455 |
|
|
1456 |
TABLE is a list of lists where each element represents one row. |
|
1457 |
It is assumed each row has the same length. |
|
1458 |
|
|
1459 |
Each row is transformed such that only the specified COLUMNS are |
|
1460 |
selected. |
|
1461 |
|
|
1462 |
See also: `-select-column', `-select-by-indices'" |
|
1463 |
(declare (pure t) (side-effect-free t)) |
|
1464 |
(--map (-select-by-indices columns it) table)) |
|
1465 |
|
|
1466 |
(defun -select-column (column table) |
|
1467 |
"Select COLUMN from TABLE. |
|
1468 |
|
|
1469 |
TABLE is a list of lists where each element represents one row. |
|
1470 |
It is assumed each row has the same length. |
|
1471 |
|
|
1472 |
The single selected column is returned as a list. |
|
1473 |
|
|
1474 |
See also: `-select-columns', `-select-by-indices'" |
|
1475 |
(declare (pure t) (side-effect-free t)) |
|
1476 |
(--mapcat (-select-by-indices (list column) it) table)) |
|
1477 |
|
|
1478 |
(defmacro -> (x &optional form &rest more) |
|
1479 |
"Thread the expr through the forms. Insert X as the second item |
|
1480 |
in the first form, making a list of it if it is not a list |
|
1481 |
already. If there are more forms, insert the first form as the |
|
1482 |
second item in second form, etc." |
|
1483 |
(declare (debug (form &rest [&or symbolp (sexp &rest form)]))) |
|
1484 |
(cond |
|
1485 |
((null form) x) |
|
1486 |
((null more) (if (listp form) |
|
1487 |
`(,(car form) ,x ,@(cdr form)) |
|
1488 |
(list form x))) |
|
1489 |
(:else `(-> (-> ,x ,form) ,@more)))) |
|
1490 |
|
|
1491 |
(defmacro ->> (x &optional form &rest more) |
|
1492 |
"Thread the expr through the forms. Insert X as the last item |
|
1493 |
in the first form, making a list of it if it is not a list |
|
1494 |
already. If there are more forms, insert the first form as the |
|
1495 |
last item in second form, etc." |
|
1496 |
(declare (debug ->)) |
|
1497 |
(cond |
|
1498 |
((null form) x) |
|
1499 |
((null more) (if (listp form) |
|
1500 |
`(,@form ,x) |
|
1501 |
(list form x))) |
|
1502 |
(:else `(->> (->> ,x ,form) ,@more)))) |
|
1503 |
|
|
1504 |
(defmacro --> (x &rest forms) |
|
1505 |
"Starting with the value of X, thread each expression through FORMS. |
|
1506 |
|
|
1507 |
Insert X at the position signified by the symbol `it' in the first |
|
1508 |
form. If there are more forms, insert the first form at the position |
|
1509 |
signified by `it' in in second form, etc." |
|
1510 |
(declare (debug (form body))) |
|
1511 |
`(-as-> ,x it ,@forms)) |
|
1512 |
|
|
1513 |
(defmacro -as-> (value variable &rest forms) |
|
1514 |
"Starting with VALUE, thread VARIABLE through FORMS. |
|
1515 |
|
|
1516 |
In the first form, bind VARIABLE to VALUE. In the second form, bind |
|
1517 |
VARIABLE to the result of the first form, and so forth." |
|
1518 |
(declare (debug (form symbolp body))) |
|
1519 |
(if (null forms) |
|
1520 |
`,value |
|
1521 |
`(let ((,variable ,value)) |
|
1522 |
(-as-> ,(if (symbolp (car forms)) |
|
1523 |
(list (car forms) variable) |
|
1524 |
(car forms)) |
|
1525 |
,variable |
|
1526 |
,@(cdr forms))))) |
|
1527 |
|
|
1528 |
(defmacro -some-> (x &optional form &rest more) |
|
1529 |
"When expr is non-nil, thread it through the first form (via `->'), |
|
1530 |
and when that result is non-nil, through the next form, etc." |
|
1531 |
(declare (debug ->)) |
|
1532 |
(if (null form) x |
|
1533 |
(let ((result (make-symbol "result"))) |
|
1534 |
`(-some-> (-when-let (,result ,x) |
|
1535 |
(-> ,result ,form)) |
|
1536 |
,@more)))) |
|
1537 |
|
|
1538 |
(defmacro -some->> (x &optional form &rest more) |
|
1539 |
"When expr is non-nil, thread it through the first form (via `->>'), |
|
1540 |
and when that result is non-nil, through the next form, etc." |
|
1541 |
(declare (debug ->)) |
|
1542 |
(if (null form) x |
|
1543 |
(let ((result (make-symbol "result"))) |
|
1544 |
`(-some->> (-when-let (,result ,x) |
|
1545 |
(->> ,result ,form)) |
|
1546 |
,@more)))) |
|
1547 |
|
|
1548 |
(defmacro -some--> (x &optional form &rest more) |
|
1549 |
"When expr in non-nil, thread it through the first form (via `-->'), |
|
1550 |
and when that result is non-nil, through the next form, etc." |
|
1551 |
(declare (debug ->)) |
|
1552 |
(if (null form) x |
|
1553 |
(let ((result (make-symbol "result"))) |
|
1554 |
`(-some--> (-when-let (,result ,x) |
|
1555 |
(--> ,result ,form)) |
|
1556 |
,@more)))) |
|
1557 |
|
|
1558 |
(defun -grade-up (comparator list) |
|
1559 |
"Grade elements of LIST using COMPARATOR relation, yielding a |
|
1560 |
permutation vector such that applying this permutation to LIST |
|
1561 |
sorts it in ascending order." |
|
1562 |
;; ugly hack to "fix" lack of lexical scope |
|
1563 |
(let ((comp `(lambda (it other) (funcall ',comparator (car it) (car other))))) |
|
1564 |
(->> (--map-indexed (cons it it-index) list) |
|
1565 |
(-sort comp) |
|
1566 |
(-map 'cdr)))) |
|
1567 |
|
|
1568 |
(defun -grade-down (comparator list) |
|
1569 |
"Grade elements of LIST using COMPARATOR relation, yielding a |
|
1570 |
permutation vector such that applying this permutation to LIST |
|
1571 |
sorts it in descending order." |
|
1572 |
;; ugly hack to "fix" lack of lexical scope |
|
1573 |
(let ((comp `(lambda (it other) (funcall ',comparator (car other) (car it))))) |
|
1574 |
(->> (--map-indexed (cons it it-index) list) |
|
1575 |
(-sort comp) |
|
1576 |
(-map 'cdr)))) |
|
1577 |
|
|
1578 |
(defvar dash--source-counter 0 |
|
1579 |
"Monotonic counter for generated symbols.") |
|
1580 |
|
|
1581 |
(defun dash--match-make-source-symbol () |
|
1582 |
"Generate a new dash-source symbol. |
|
1583 |
|
|
1584 |
All returned symbols are guaranteed to be unique." |
|
1585 |
(prog1 (make-symbol (format "--dash-source-%d--" dash--source-counter)) |
|
1586 |
(setq dash--source-counter (1+ dash--source-counter)))) |
|
1587 |
|
|
1588 |
(defun dash--match-ignore-place-p (symbol) |
|
1589 |
"Return non-nil if SYMBOL is a symbol and starts with _." |
|
1590 |
(and (symbolp symbol) |
|
1591 |
(eq (aref (symbol-name symbol) 0) ?_))) |
|
1592 |
|
|
1593 |
(defun dash--match-cons-skip-cdr (skip-cdr source) |
|
1594 |
"Helper function generating idiomatic shifting code." |
|
1595 |
(cond |
|
1596 |
((= skip-cdr 0) |
|
1597 |
`(pop ,source)) |
|
1598 |
(t |
|
1599 |
`(prog1 ,(dash--match-cons-get-car skip-cdr source) |
|
1600 |
(setq ,source ,(dash--match-cons-get-cdr (1+ skip-cdr) source)))))) |
|
1601 |
|
|
1602 |
(defun dash--match-cons-get-car (skip-cdr source) |
|
1603 |
"Helper function generating idiomatic code to get nth car." |
|
1604 |
(cond |
|
1605 |
((= skip-cdr 0) |
|
1606 |
`(car ,source)) |
|
1607 |
((= skip-cdr 1) |
|
1608 |
`(cadr ,source)) |
|
1609 |
(t |
|
1610 |
`(nth ,skip-cdr ,source)))) |
|
1611 |
|
|
1612 |
(defun dash--match-cons-get-cdr (skip-cdr source) |
|
1613 |
"Helper function generating idiomatic code to get nth cdr." |
|
1614 |
(cond |
|
1615 |
((= skip-cdr 0) |
|
1616 |
source) |
|
1617 |
((= skip-cdr 1) |
|
1618 |
`(cdr ,source)) |
|
1619 |
(t |
|
1620 |
`(nthcdr ,skip-cdr ,source)))) |
|
1621 |
|
|
1622 |
(defun dash--match-cons (match-form source) |
|
1623 |
"Setup a cons matching environment and call the real matcher." |
|
1624 |
(let ((s (dash--match-make-source-symbol)) |
|
1625 |
(n 0) |
|
1626 |
(m match-form)) |
|
1627 |
(while (and (consp m) |
|
1628 |
(dash--match-ignore-place-p (car m))) |
|
1629 |
(setq n (1+ n)) (!cdr m)) |
|
1630 |
(cond |
|
1631 |
;; when we only have one pattern in the list, we don't have to |
|
1632 |
;; create a temporary binding (--dash-source--) for the source |
|
1633 |
;; and just use the input directly |
|
1634 |
((and (consp m) |
|
1635 |
(not (cdr m))) |
|
1636 |
(dash--match (car m) (dash--match-cons-get-car n source))) |
|
1637 |
;; handle other special types |
|
1638 |
((> n 0) |
|
1639 |
(dash--match m (dash--match-cons-get-cdr n source))) |
|
1640 |
;; this is the only entry-point for dash--match-cons-1, that's |
|
1641 |
;; why we can't simply use the above branch, it would produce |
|
1642 |
;; infinite recursion |
|
1643 |
(t |
|
1644 |
(cons (list s source) (dash--match-cons-1 match-form s)))))) |
|
1645 |
|
|
1646 |
(defun dash--match-cons-1 (match-form source &optional props) |
|
1647 |
"Match MATCH-FORM against SOURCE. |
|
1648 |
|
|
1649 |
MATCH-FORM is a proper or improper list. Each element of |
|
1650 |
MATCH-FORM is either a symbol, which gets bound to the respective |
|
1651 |
value in source or another match form which gets destructured |
|
1652 |
recursively. |
|
1653 |
|
|
1654 |
If the cdr of last cons cell in the list is `nil', matching stops |
|
1655 |
there. |
|
1656 |
|
|
1657 |
SOURCE is a proper or improper list." |
|
1658 |
(let ((skip-cdr (or (plist-get props :skip-cdr) 0))) |
|
1659 |
(cond |
|
1660 |
((consp match-form) |
|
1661 |
(cond |
|
1662 |
((cdr match-form) |
|
1663 |
(cond |
|
1664 |
((and (symbolp (car match-form)) |
|
1665 |
(memq (car match-form) '(&keys &plist &alist &hash))) |
|
1666 |
(dash--match-kv (dash--match-kv-normalize-match-form match-form) (dash--match-cons-get-cdr skip-cdr source))) |
|
1667 |
((dash--match-ignore-place-p (car match-form)) |
|
1668 |
(dash--match-cons-1 (cdr match-form) source |
|
1669 |
(plist-put props :skip-cdr (1+ skip-cdr)))) |
|
1670 |
(t |
|
1671 |
(-concat (dash--match (car match-form) (dash--match-cons-skip-cdr skip-cdr source)) |
|
1672 |
(dash--match-cons-1 (cdr match-form) source))))) |
|
1673 |
(t ;; Last matching place, no need for shift |
|
1674 |
(dash--match (car match-form) (dash--match-cons-get-car skip-cdr source))))) |
|
1675 |
((eq match-form nil) |
|
1676 |
nil) |
|
1677 |
(t ;; Handle improper lists. Last matching place, no need for shift |
|
1678 |
(dash--match match-form (dash--match-cons-get-cdr skip-cdr source)))))) |
|
1679 |
|
|
1680 |
(defun dash--vector-tail (seq start) |
|
1681 |
"Return the tail of SEQ starting at START." |
|
1682 |
(cond |
|
1683 |
((vectorp seq) |
|
1684 |
(let* ((re-length (- (length seq) start)) |
|
1685 |
(re (make-vector re-length 0))) |
|
1686 |
(--dotimes re-length (aset re it (aref seq (+ it start)))) |
|
1687 |
re)) |
|
1688 |
((stringp seq) |
|
1689 |
(substring seq start)))) |
|
1690 |
|
|
1691 |
(defun dash--match-vector (match-form source) |
|
1692 |
"Setup a vector matching environment and call the real matcher." |
|
1693 |
(let ((s (dash--match-make-source-symbol))) |
|
1694 |
(cond |
|
1695 |
;; don't bind `s' if we only have one sub-pattern |
|
1696 |
((= (length match-form) 1) |
|
1697 |
(dash--match (aref match-form 0) `(aref ,source 0))) |
|
1698 |
;; if the source is a symbol, we don't need to re-bind it |
|
1699 |
((symbolp source) |
|
1700 |
(dash--match-vector-1 match-form source)) |
|
1701 |
;; don't bind `s' if we only have one sub-pattern which is not ignored |
|
1702 |
((let* ((ignored-places (mapcar 'dash--match-ignore-place-p match-form)) |
|
1703 |
(ignored-places-n (length (-remove 'null ignored-places)))) |
|
1704 |
(when (= ignored-places-n (1- (length match-form))) |
|
1705 |
(let ((n (-find-index 'null ignored-places))) |
|
1706 |
(dash--match (aref match-form n) `(aref ,source ,n)))))) |
|
1707 |
(t |
|
1708 |
(cons (list s source) (dash--match-vector-1 match-form s)))))) |
|
1709 |
|
|
1710 |
(defun dash--match-vector-1 (match-form source) |
|
1711 |
"Match MATCH-FORM against SOURCE. |
|
1712 |
|
|
1713 |
MATCH-FORM is a vector. Each element of MATCH-FORM is either a |
|
1714 |
symbol, which gets bound to the respective value in source or |
|
1715 |
another match form which gets destructured recursively. |
|
1716 |
|
|
1717 |
If second-from-last place in MATCH-FORM is the symbol &rest, the |
|
1718 |
next element of the MATCH-FORM is matched against the tail of |
|
1719 |
SOURCE, starting at index of the &rest symbol. This is |
|
1720 |
conceptually the same as the (head . tail) match for improper |
|
1721 |
lists, where dot plays the role of &rest. |
|
1722 |
|
|
1723 |
SOURCE is a vector. |
|
1724 |
|
|
1725 |
If the MATCH-FORM vector is shorter than SOURCE vector, only |
|
1726 |
the (length MATCH-FORM) places are bound, the rest of the SOURCE |
|
1727 |
is discarded." |
|
1728 |
(let ((i 0) |
|
1729 |
(l (length match-form)) |
|
1730 |
(re)) |
|
1731 |
(while (< i l) |
|
1732 |
(let ((m (aref match-form i))) |
|
1733 |
(push (cond |
|
1734 |
((and (symbolp m) |
|
1735 |
(eq m '&rest)) |
|
1736 |
(prog1 (dash--match |
|
1737 |
(aref match-form (1+ i)) |
|
1738 |
`(dash--vector-tail ,source ,i)) |
|
1739 |
(setq i l))) |
|
1740 |
((and (symbolp m) |
|
1741 |
;; do not match symbols starting with _ |
|
1742 |
(not (eq (aref (symbol-name m) 0) ?_))) |
|
1743 |
(list (list m `(aref ,source ,i)))) |
|
1744 |
((not (symbolp m)) |
|
1745 |
(dash--match m `(aref ,source ,i)))) |
|
1746 |
re) |
|
1747 |
(setq i (1+ i)))) |
|
1748 |
(-flatten-n 1 (nreverse re)))) |
|
1749 |
|
|
1750 |
(defun dash--match-kv-normalize-match-form (pattern) |
|
1751 |
"Normalize kv PATTERN. |
|
1752 |
|
|
1753 |
This method normalizes PATTERN to the format expected by |
|
1754 |
`dash--match-kv'. See `-let' for the specification." |
|
1755 |
(let ((normalized (list (car pattern))) |
|
1756 |
(skip nil) |
|
1757 |
(fill-placeholder (make-symbol "--dash-fill-placeholder--"))) |
|
1758 |
(-each (apply '-zip (-pad fill-placeholder (cdr pattern) (cddr pattern))) |
|
1759 |
(lambda (pair) |
|
1760 |
(let ((current (car pair)) |
|
1761 |
(next (cdr pair))) |
|
1762 |
(if skip |
|
1763 |
(setq skip nil) |
|
1764 |
(if (or (eq fill-placeholder next) |
|
1765 |
(not (or (and (symbolp next) |
|
1766 |
(not (keywordp next)) |
|
1767 |
(not (eq next t)) |
|
1768 |
(not (eq next nil))) |
|
1769 |
(and (consp next) |
|
1770 |
(not (eq (car next) 'quote))) |
|
1771 |
(vectorp next)))) |
|
1772 |
(progn |
|
1773 |
(cond |
|
1774 |
((keywordp current) |
|
1775 |
(push current normalized) |
|
1776 |
(push (intern (substring (symbol-name current) 1)) normalized)) |
|
1777 |
((stringp current) |
|
1778 |
(push current normalized) |
|
1779 |
(push (intern current) normalized)) |
|
1780 |
((and (consp current) |
|
1781 |
(eq (car current) 'quote)) |
|
1782 |
(push current normalized) |
|
1783 |
(push (cadr current) normalized)) |
|
1784 |
(t (error "-let: found key `%s' in kv destructuring but its pattern `%s' is invalid and can not be derived from the key" current next))) |
|
1785 |
(setq skip nil)) |
|
1786 |
(push current normalized) |
|
1787 |
(push next normalized) |
|
1788 |
(setq skip t)))))) |
|
1789 |
(nreverse normalized))) |
|
1790 |
|
|
1791 |
(defun dash--match-kv (match-form source) |
|
1792 |
"Setup a kv matching environment and call the real matcher. |
|
1793 |
|
|
1794 |
kv can be any key-value store, such as plist, alist or hash-table." |
|
1795 |
(let ((s (dash--match-make-source-symbol))) |
|
1796 |
(cond |
|
1797 |
;; don't bind `s' if we only have one sub-pattern (&type key val) |
|
1798 |
((= (length match-form) 3) |
|
1799 |
(dash--match-kv-1 (cdr match-form) source (car match-form))) |
|
1800 |
;; if the source is a symbol, we don't need to re-bind it |
|
1801 |
((symbolp source) |
|
1802 |
(dash--match-kv-1 (cdr match-form) source (car match-form))) |
|
1803 |
(t |
|
1804 |
(cons (list s source) (dash--match-kv-1 (cdr match-form) s (car match-form))))))) |
|
1805 |
|
|
1806 |
(defun dash--match-kv-1 (match-form source type) |
|
1807 |
"Match MATCH-FORM against SOURCE of type TYPE. |
|
1808 |
|
|
1809 |
MATCH-FORM is a proper list of the form (key1 place1 ... keyN |
|
1810 |
placeN). Each placeK is either a symbol, which gets bound to the |
|
1811 |
value of keyK retrieved from the key-value store, or another |
|
1812 |
match form which gets destructured recursively. |
|
1813 |
|
|
1814 |
SOURCE is a key-value store of type TYPE, which can be a plist, |
|
1815 |
an alist or a hash table. |
|
1816 |
|
|
1817 |
TYPE is a token specifying the type of the key-value store. |
|
1818 |
Valid values are &plist, &alist and &hash." |
|
1819 |
(-flatten-n 1 (-map |
|
1820 |
(lambda (kv) |
|
1821 |
(let* ((k (car kv)) |
|
1822 |
(v (cadr kv)) |
|
1823 |
(getter (cond |
|
1824 |
((or (eq type '&plist) (eq type '&keys)) |
|
1825 |
`(plist-get ,source ,k)) |
|
1826 |
((eq type '&alist) |
|
1827 |
`(cdr (assoc ,k ,source))) |
|
1828 |
((eq type '&hash) |
|
1829 |
`(gethash ,k ,source))))) |
|
1830 |
(cond |
|
1831 |
((symbolp v) |
|
1832 |
(list (list v getter))) |
|
1833 |
(t (dash--match v getter))))) |
|
1834 |
(-partition 2 match-form)))) |
|
1835 |
|
|
1836 |
(defun dash--match-symbol (match-form source) |
|
1837 |
"Bind a symbol. |
|
1838 |
|
|
1839 |
This works just like `let', there is no destructuring." |
|
1840 |
(list (list match-form source))) |
|
1841 |
|
|
1842 |
(defun dash--match (match-form source) |
|
1843 |
"Match MATCH-FORM against SOURCE. |
|
1844 |
|
|
1845 |
This function tests the MATCH-FORM and dispatches to specific |
|
1846 |
matchers based on the type of the expression. |
|
1847 |
|
|
1848 |
Key-value stores are disambiguated by placing a token &plist, |
|
1849 |
&alist or &hash as a first item in the MATCH-FORM." |
|
1850 |
(cond |
|
1851 |
((symbolp match-form) |
|
1852 |
(dash--match-symbol match-form source)) |
|
1853 |
((consp match-form) |
|
1854 |
(cond |
|
1855 |
;; Handle the "x &as" bindings first. |
|
1856 |
((and (consp (cdr match-form)) |
|
1857 |
(symbolp (car match-form)) |
|
1858 |
(eq '&as (cadr match-form))) |
|
1859 |
(let ((s (car match-form))) |
|
1860 |
(cons (list s source) |
|
1861 |
(dash--match (cddr match-form) s)))) |
|
1862 |
((memq (car match-form) '(&keys &plist &alist &hash)) |
|
1863 |
(dash--match-kv (dash--match-kv-normalize-match-form match-form) source)) |
|
1864 |
(t (dash--match-cons match-form source)))) |
|
1865 |
((vectorp match-form) |
|
1866 |
;; We support the &as binding in vectors too |
|
1867 |
(cond |
|
1868 |
((and (> (length match-form) 2) |
|
1869 |
(symbolp (aref match-form 0)) |
|
1870 |
(eq '&as (aref match-form 1))) |
|
1871 |
(let ((s (aref match-form 0))) |
|
1872 |
(cons (list s source) |
|
1873 |
(dash--match (dash--vector-tail match-form 2) s)))) |
|
1874 |
(t (dash--match-vector match-form source)))))) |
|
1875 |
|
|
1876 |
(defun dash--normalize-let-varlist (varlist) |
|
1877 |
"Normalize VARLIST so that every binding is a list. |
|
1878 |
|
|
1879 |
`let' allows specifying a binding which is not a list but simply |
|
1880 |
the place which is then automatically bound to nil, such that all |
|
1881 |
three of the following are identical and evaluate to nil. |
|
1882 |
|
|
1883 |
(let (a) a) |
|
1884 |
(let ((a)) a) |
|
1885 |
(let ((a nil)) a) |
|
1886 |
|
|
1887 |
This function normalizes all of these to the last form." |
|
1888 |
(--map (if (consp it) it (list it nil)) varlist)) |
|
1889 |
|
|
1890 |
(defmacro -let* (varlist &rest body) |
|
1891 |
"Bind variables according to VARLIST then eval BODY. |
|
1892 |
|
|
1893 |
VARLIST is a list of lists of the form (PATTERN SOURCE). Each |
|
1894 |
PATTERN is matched against the SOURCE structurally. SOURCE is |
|
1895 |
only evaluated once for each PATTERN. |
|
1896 |
|
|
1897 |
Each SOURCE can refer to the symbols already bound by this |
|
1898 |
VARLIST. This is useful if you want to destructure SOURCE |
|
1899 |
recursively but also want to name the intermediate structures. |
|
1900 |
|
|
1901 |
See `-let' for the list of all possible patterns." |
|
1902 |
(declare (debug ((&rest [&or (sexp form) sexp]) body)) |
|
1903 |
(indent 1)) |
|
1904 |
(let* ((varlist (dash--normalize-let-varlist varlist)) |
|
1905 |
(bindings (--mapcat (dash--match (car it) (cadr it)) varlist))) |
|
1906 |
`(let* ,bindings |
|
1907 |
,@body))) |
|
1908 |
|
|
1909 |
(defmacro -let (varlist &rest body) |
|
1910 |
"Bind variables according to VARLIST then eval BODY. |
|
1911 |
|
|
1912 |
VARLIST is a list of lists of the form (PATTERN SOURCE). Each |
|
1913 |
PATTERN is matched against the SOURCE \"structurally\". SOURCE |
|
1914 |
is only evaluated once for each PATTERN. Each PATTERN is matched |
|
1915 |
recursively, and can therefore contain sub-patterns which are |
|
1916 |
matched against corresponding sub-expressions of SOURCE. |
|
1917 |
|
|
1918 |
All the SOURCEs are evalled before any symbols are |
|
1919 |
bound (i.e. \"in parallel\"). |
|
1920 |
|
|
1921 |
If VARLIST only contains one (PATTERN SOURCE) element, you can |
|
1922 |
optionally specify it using a vector and discarding the |
|
1923 |
outer-most parens. Thus |
|
1924 |
|
|
1925 |
(-let ((PATTERN SOURCE)) ..) |
|
1926 |
|
|
1927 |
becomes |
|
1928 |
|
|
1929 |
(-let [PATTERN SOURCE] ..). |
|
1930 |
|
|
1931 |
`-let' uses a convention of not binding places (symbols) starting |
|
1932 |
with _ whenever it's possible. You can use this to skip over |
|
1933 |
entries you don't care about. However, this is not *always* |
|
1934 |
possible (as a result of implementation) and these symbols might |
|
1935 |
get bound to undefined values. |
|
1936 |
|
|
1937 |
Following is the overview of supported patterns. Remember that |
|
1938 |
patterns can be matched recursively, so every a, b, aK in the |
|
1939 |
following can be a matching construct and not necessarily a |
|
1940 |
symbol/variable. |
|
1941 |
|
|
1942 |
Symbol: |
|
1943 |
|
|
1944 |
a - bind the SOURCE to A. This is just like regular `let'. |
|
1945 |
|
|
1946 |
Conses and lists: |
|
1947 |
|
|
1948 |
(a) - bind `car' of cons/list to A |
|
1949 |
|
|
1950 |
(a . b) - bind car of cons to A and `cdr' to B |
|
1951 |
|
|
1952 |
(a b) - bind car of list to A and `cadr' to B |
|
1953 |
|
|
1954 |
(a1 a2 a3 ...) - bind 0th car of list to A1, 1st to A2, 2nd to A3 ... |
|
1955 |
|
|
1956 |
(a1 a2 a3 ... aN . rest) - as above, but bind the Nth cdr to REST. |
|
1957 |
|
|
1958 |
Vectors: |
|
1959 |
|
|
1960 |
[a] - bind 0th element of a non-list sequence to A (works with |
|
1961 |
vectors, strings, bit arrays...) |
|
1962 |
|
|
1963 |
[a1 a2 a3 ...] - bind 0th element of non-list sequence to A0, 1st to |
|
1964 |
A1, 2nd to A2, ... |
|
1965 |
If the PATTERN is shorter than SOURCE, the values at |
|
1966 |
places not in PATTERN are ignored. |
|
1967 |
If the PATTERN is longer than SOURCE, an `error' is |
|
1968 |
thrown. |
|
1969 |
|
|
1970 |
[a1 a2 a3 ... &rest rest] - as above, but bind the rest of |
|
1971 |
the sequence to REST. This is |
|
1972 |
conceptually the same as improper list |
|
1973 |
matching (a1 a2 ... aN . rest) |
|
1974 |
|
|
1975 |
Key/value stores: |
|
1976 |
|
|
1977 |
(&plist key0 a0 ... keyN aN) - bind value mapped by keyK in the |
|
1978 |
SOURCE plist to aK. If the |
|
1979 |
value is not found, aK is nil. |
|
1980 |
Uses `plist-get' to fetch values. |
|
1981 |
|
|
1982 |
(&alist key0 a0 ... keyN aN) - bind value mapped by keyK in the |
|
1983 |
SOURCE alist to aK. If the |
|
1984 |
value is not found, aK is nil. |
|
1985 |
Uses `assoc' to fetch values. |
|
1986 |
|
|
1987 |
(&hash key0 a0 ... keyN aN) - bind value mapped by keyK in the |
|
1988 |
SOURCE hash table to aK. If the |
|
1989 |
value is not found, aK is nil. |
|
1990 |
Uses `gethash' to fetch values. |
|
1991 |
|
|
1992 |
Further, special keyword &keys supports \"inline\" matching of |
|
1993 |
plist-like key-value pairs, similarly to &keys keyword of |
|
1994 |
`cl-defun'. |
|
1995 |
|
|
1996 |
(a1 a2 ... aN &keys key1 b1 ... keyN bK) |
|
1997 |
|
|
1998 |
This binds N values from the list to a1 ... aN, then interprets |
|
1999 |
the cdr as a plist (see key/value matching above). |
|
2000 |
|
|
2001 |
A shorthand notation for kv-destructuring exists which allows the |
|
2002 |
patterns be optionally left out and derived from the key name in |
|
2003 |
the following fashion: |
|
2004 |
|
|
2005 |
- a key :foo is converted into `foo' pattern, |
|
2006 |
- a key 'bar is converted into `bar' pattern, |
|
2007 |
- a key \"baz\" is converted into `baz' pattern. |
|
2008 |
|
|
2009 |
That is, the entire value under the key is bound to the derived |
|
2010 |
variable without any further destructuring. |
|
2011 |
|
|
2012 |
This is possible only when the form following the key is not a |
|
2013 |
valid pattern (i.e. not a symbol, a cons cell or a vector). |
|
2014 |
Otherwise the matching proceeds as usual and in case of an |
|
2015 |
invalid spec fails with an error. |
|
2016 |
|
|
2017 |
Thus the patterns are normalized as follows: |
|
2018 |
|
|
2019 |
;; derive all the missing patterns |
|
2020 |
(&plist :foo 'bar \"baz\") => (&plist :foo foo 'bar bar \"baz\" baz) |
|
2021 |
|
|
2022 |
;; we can specify some but not others |
|
2023 |
(&plist :foo 'bar explicit-bar) => (&plist :foo foo 'bar explicit-bar) |
|
2024 |
|
|
2025 |
;; nothing happens, we store :foo in x |
|
2026 |
(&plist :foo x) => (&plist :foo x) |
|
2027 |
|
|
2028 |
;; nothing happens, we match recursively |
|
2029 |
(&plist :foo (a b c)) => (&plist :foo (a b c)) |
|
2030 |
|
|
2031 |
You can name the source using the syntax SYMBOL &as PATTERN. |
|
2032 |
This syntax works with lists (proper or improper), vectors and |
|
2033 |
all types of maps. |
|
2034 |
|
|
2035 |
(list &as a b c) (list 1 2 3) |
|
2036 |
|
|
2037 |
binds A to 1, B to 2, C to 3 and LIST to (1 2 3). |
|
2038 |
|
|
2039 |
Similarly: |
|
2040 |
|
|
2041 |
(bounds &as beg . end) (cons 1 2) |
|
2042 |
|
|
2043 |
binds BEG to 1, END to 2 and BOUNDS to (1 . 2). |
|
2044 |
|
|
2045 |
(items &as first . rest) (list 1 2 3) |
|
2046 |
|
|
2047 |
binds FIRST to 1, REST to (2 3) and ITEMS to (1 2 3) |
|
2048 |
|
|
2049 |
[vect &as _ b c] [1 2 3] |
|
2050 |
|
|
2051 |
binds B to 2, C to 3 and VECT to [1 2 3] (_ avoids binding as usual). |
|
2052 |
|
|
2053 |
(plist &as &plist :b b) (list :a 1 :b 2 :c 3) |
|
2054 |
|
|
2055 |
binds B to 2 and PLIST to (:a 1 :b 2 :c 3). Same for &alist and &hash. |
|
2056 |
|
|
2057 |
This is especially useful when we want to capture the result of a |
|
2058 |
computation and destructure at the same time. Consider the |
|
2059 |
form (function-returning-complex-structure) returning a list of |
|
2060 |
two vectors with two items each. We want to capture this entire |
|
2061 |
result and pass it to another computation, but at the same time |
|
2062 |
we want to get the second item from each vector. We can achieve |
|
2063 |
it with pattern |
|
2064 |
|
|
2065 |
(result &as [_ a] [_ b]) (function-returning-complex-structure) |
|
2066 |
|
|
2067 |
Note: Clojure programmers may know this feature as the \":as |
|
2068 |
binding\". The difference is that we put the &as at the front |
|
2069 |
because we need to support improper list binding." |
|
2070 |
(declare (debug ([&or (&rest [&or (sexp form) sexp]) |
|
2071 |
(vector [&rest [sexp form]])] |
|
2072 |
body)) |
|
2073 |
(indent 1)) |
|
2074 |
(if (vectorp varlist) |
|
2075 |
`(let* ,(dash--match (aref varlist 0) (aref varlist 1)) |
|
2076 |
,@body) |
|
2077 |
(let* ((varlist (dash--normalize-let-varlist varlist)) |
|
2078 |
(inputs (--map-indexed (list (make-symbol (format "input%d" it-index)) (cadr it)) varlist)) |
|
2079 |
(new-varlist (--map (list (caar it) (cadr it)) (-zip varlist inputs)))) |
|
2080 |
`(let ,inputs |
|
2081 |
(-let* ,new-varlist ,@body))))) |
|
2082 |
|
|
2083 |
(defmacro -lambda (match-form &rest body) |
|
2084 |
"Return a lambda which destructures its input as MATCH-FORM and executes BODY. |
|
2085 |
|
|
2086 |
Note that you have to enclose the MATCH-FORM in a pair of parens, |
|
2087 |
such that: |
|
2088 |
|
|
2089 |
(-lambda (x) body) |
|
2090 |
(-lambda (x y ...) body) |
|
2091 |
|
|
2092 |
has the usual semantics of `lambda'. Furthermore, these get |
|
2093 |
translated into normal lambda, so there is no performance |
|
2094 |
penalty. |
|
2095 |
|
|
2096 |
See `-let' for the description of destructuring mechanism." |
|
2097 |
(declare (doc-string 2) (indent defun) |
|
2098 |
(debug (&define sexp |
|
2099 |
[&optional stringp] |
|
2100 |
[&optional ("interactive" interactive)] |
|
2101 |
def-body))) |
|
2102 |
(cond |
|
2103 |
((not (consp match-form)) |
|
2104 |
(signal 'wrong-type-argument "match-form must be a list")) |
|
2105 |
;; no destructuring, so just return regular lambda to make things faster |
|
2106 |
((-all? 'symbolp match-form) |
|
2107 |
`(lambda ,match-form ,@body)) |
|
2108 |
(t |
|
2109 |
(let* ((inputs (--map-indexed (list it (make-symbol (format "input%d" it-index))) match-form))) |
|
2110 |
;; TODO: because inputs to the lambda are evaluated only once, |
|
2111 |
;; -let* need not to create the extra bindings to ensure that. |
|
2112 |
;; We should find a way to optimize that. Not critical however. |
|
2113 |
`(lambda ,(--map (cadr it) inputs) |
|
2114 |
(-let* ,inputs ,@body)))))) |
|
2115 |
|
|
2116 |
(defmacro -setq (&rest forms) |
|
2117 |
"Bind each MATCH-FORM to the value of its VAL. |
|
2118 |
|
|
2119 |
MATCH-FORM destructuring is done according to the rules of `-let'. |
|
2120 |
|
|
2121 |
This macro allows you to bind multiple variables by destructuring |
|
2122 |
the value, so for example: |
|
2123 |
|
|
2124 |
(-setq (a b) x |
|
2125 |
(&plist :c c) plist) |
|
2126 |
|
|
2127 |
expands roughly speaking to the following code |
|
2128 |
|
|
2129 |
(setq a (car x) |
|
2130 |
b (cadr x) |
|
2131 |
c (plist-get plist :c)) |
|
2132 |
|
|
2133 |
Care is taken to only evaluate each VAL once so that in case of |
|
2134 |
multiple assignments it does not cause unexpected side effects. |
|
2135 |
|
|
2136 |
\(fn [MATCH-FORM VAL]...)" |
|
2137 |
(declare (debug (&rest sexp form)) |
|
2138 |
(indent 1)) |
|
2139 |
(when (= (mod (length forms) 2) 1) |
|
2140 |
(error "Odd number of arguments")) |
|
2141 |
(let* ((forms-and-sources |
|
2142 |
;; First get all the necessary mappings with all the |
|
2143 |
;; intermediate bindings. |
|
2144 |
(-map (lambda (x) (dash--match (car x) (cadr x))) |
|
2145 |
(-partition 2 forms))) |
|
2146 |
;; To preserve the logic of dynamic scoping we must ensure |
|
2147 |
;; that we `setq' the variables outside of the `let*' form |
|
2148 |
;; which holds the destructured intermediate values. For |
|
2149 |
;; this we generate for each variable a placeholder which is |
|
2150 |
;; bound to (lexically) the result of the destructuring. |
|
2151 |
;; Then outside of the helper `let*' form we bind all the |
|
2152 |
;; original variables to their respective placeholders. |
|
2153 |
;; TODO: There is a lot of room for possible optimization, |
|
2154 |
;; for start playing with `special-variable-p' to eliminate |
|
2155 |
;; unnecessary re-binding. |
|
2156 |
(variables-to-placeholders |
|
2157 |
(-mapcat |
|
2158 |
(lambda (bindings) |
|
2159 |
(-map |
|
2160 |
(lambda (binding) |
|
2161 |
(let ((var (car binding))) |
|
2162 |
(list var (make-symbol (concat "--dash-binding-" (symbol-name var) "--"))))) |
|
2163 |
(--filter (not (string-prefix-p "--" (symbol-name (car it)))) bindings))) |
|
2164 |
forms-and-sources))) |
|
2165 |
`(let ,(-map 'cadr variables-to-placeholders) |
|
2166 |
(let* ,(-flatten-n 1 forms-and-sources) |
|
2167 |
(setq ,@(-flatten (-map 'reverse variables-to-placeholders)))) |
|
2168 |
(setq ,@(-flatten variables-to-placeholders))))) |
|
2169 |
|
|
2170 |
(defmacro -if-let* (vars-vals then &rest else) |
|
2171 |
"If all VALS evaluate to true, bind them to their corresponding |
|
2172 |
VARS and do THEN, otherwise do ELSE. VARS-VALS should be a list |
|
2173 |
of (VAR VAL) pairs. |
|
2174 |
|
|
2175 |
Note: binding is done according to `-let*'. VALS are evaluated |
|
2176 |
sequentially, and evaluation stops after the first nil VAL is |
|
2177 |
encountered." |
|
2178 |
(declare (debug ((&rest (sexp form)) form body)) |
|
2179 |
(indent 2)) |
|
2180 |
(->> vars-vals |
|
2181 |
(--mapcat (dash--match (car it) (cadr it))) |
|
2182 |
(--reduce-r-from |
|
2183 |
(let ((var (car it)) |
|
2184 |
(val (cadr it))) |
|
2185 |
`(let ((,var ,val)) |
|
2186 |
(if ,var ,acc ,@else))) |
|
2187 |
then))) |
|
2188 |
|
|
2189 |
(defmacro -if-let (var-val then &rest else) |
|
2190 |
"If VAL evaluates to non-nil, bind it to VAR and do THEN, |
|
2191 |
otherwise do ELSE. |
|
2192 |
|
|
2193 |
Note: binding is done according to `-let'. |
|
2194 |
|
|
2195 |
\(fn (VAR VAL) THEN &rest ELSE)" |
|
2196 |
(declare (debug ((sexp form) form body)) |
|
2197 |
(indent 2)) |
|
2198 |
`(-if-let* (,var-val) ,then ,@else)) |
|
2199 |
|
|
2200 |
(defmacro --if-let (val then &rest else) |
|
2201 |
"If VAL evaluates to non-nil, bind it to symbol `it' and do THEN, |
|
2202 |
otherwise do ELSE." |
|
2203 |
(declare (debug (form form body)) |
|
2204 |
(indent 2)) |
|
2205 |
`(-if-let (it ,val) ,then ,@else)) |
|
2206 |
|
|
2207 |
(defmacro -when-let* (vars-vals &rest body) |
|
2208 |
"If all VALS evaluate to true, bind them to their corresponding |
|
2209 |
VARS and execute body. VARS-VALS should be a list of (VAR VAL) |
|
2210 |
pairs. |
|
2211 |
|
|
2212 |
Note: binding is done according to `-let*'. VALS are evaluated |
|
2213 |
sequentially, and evaluation stops after the first nil VAL is |
|
2214 |
encountered." |
|
2215 |
(declare (debug ((&rest (sexp form)) body)) |
|
2216 |
(indent 1)) |
|
2217 |
`(-if-let* ,vars-vals (progn ,@body))) |
|
2218 |
|
|
2219 |
(defmacro -when-let (var-val &rest body) |
|
2220 |
"If VAL evaluates to non-nil, bind it to VAR and execute body. |
|
2221 |
|
|
2222 |
Note: binding is done according to `-let'. |
|
2223 |
|
|
2224 |
\(fn (VAR VAL) &rest BODY)" |
|
2225 |
(declare (debug ((sexp form) body)) |
|
2226 |
(indent 1)) |
|
2227 |
`(-if-let ,var-val (progn ,@body))) |
|
2228 |
|
|
2229 |
(defmacro --when-let (val &rest body) |
|
2230 |
"If VAL evaluates to non-nil, bind it to symbol `it' and |
|
2231 |
execute body." |
|
2232 |
(declare (debug (form body)) |
|
2233 |
(indent 1)) |
|
2234 |
`(--if-let ,val (progn ,@body))) |
|
2235 |
|
|
2236 |
(defvar -compare-fn nil |
|
2237 |
"Tests for equality use this function or `equal' if this is nil. |
|
2238 |
It should only be set using dynamic scope with a let, like: |
|
2239 |
|
|
2240 |
(let ((-compare-fn #\\='=)) (-union numbers1 numbers2 numbers3)") |
|
2241 |
|
|
2242 |
(defun -distinct (list) |
|
2243 |
"Return a new list with all duplicates removed. |
|
2244 |
The test for equality is done with `equal', |
|
2245 |
or with `-compare-fn' if that's non-nil. |
|
2246 |
|
|
2247 |
Alias: `-uniq'" |
|
2248 |
(let (result) |
|
2249 |
(--each list (unless (-contains? result it) (!cons it result))) |
|
2250 |
(nreverse result))) |
|
2251 |
|
|
2252 |
(defalias '-uniq '-distinct) |
|
2253 |
|
|
2254 |
(defun -union (list list2) |
|
2255 |
"Return a new list containing the elements of LIST and elements of LIST2 that are not in LIST. |
|
2256 |
The test for equality is done with `equal', |
|
2257 |
or with `-compare-fn' if that's non-nil." |
|
2258 |
;; We fall back to iteration implementation if the comparison |
|
2259 |
;; function isn't one of `eq', `eql' or `equal'. |
|
2260 |
(let* ((result (reverse list)) |
|
2261 |
;; TODO: get rid of this dynamic variable, pass it as an |
|
2262 |
;; argument instead. |
|
2263 |
(-compare-fn (if (bound-and-true-p -compare-fn) |
|
2264 |
-compare-fn |
|
2265 |
'equal))) |
|
2266 |
(if (memq -compare-fn '(eq eql equal)) |
|
2267 |
(let ((ht (make-hash-table :test -compare-fn))) |
|
2268 |
(--each list (puthash it t ht)) |
|
2269 |
(--each list2 (unless (gethash it ht) (!cons it result)))) |
|
2270 |
(--each list2 (unless (-contains? result it) (!cons it result)))) |
|
2271 |
(nreverse result))) |
|
2272 |
|
|
2273 |
(defun -intersection (list list2) |
|
2274 |
"Return a new list containing only the elements that are members of both LIST and LIST2. |
|
2275 |
The test for equality is done with `equal', |
|
2276 |
or with `-compare-fn' if that's non-nil." |
|
2277 |
(--filter (-contains? list2 it) list)) |
|
2278 |
|
|
2279 |
(defun -difference (list list2) |
|
2280 |
"Return a new list with only the members of LIST that are not in LIST2. |
|
2281 |
The test for equality is done with `equal', |
|
2282 |
or with `-compare-fn' if that's non-nil." |
|
2283 |
(--filter (not (-contains? list2 it)) list)) |
|
2284 |
|
|
2285 |
(defun -powerset (list) |
|
2286 |
"Return the power set of LIST." |
|
2287 |
(if (null list) '(()) |
|
2288 |
(let ((last (-powerset (cdr list)))) |
|
2289 |
(append (mapcar (lambda (x) (cons (car list) x)) last) |
|
2290 |
last)))) |
|
2291 |
|
|
2292 |
(defun -permutations (list) |
|
2293 |
"Return the permutations of LIST." |
|
2294 |
(if (null list) '(()) |
|
2295 |
(apply #'append |
|
2296 |
(mapcar (lambda (x) |
|
2297 |
(mapcar (lambda (perm) (cons x perm)) |
|
2298 |
(-permutations (remove x list)))) |
|
2299 |
list)))) |
|
2300 |
|
|
2301 |
(defun -inits (list) |
|
2302 |
"Return all prefixes of LIST." |
|
2303 |
(nreverse (-map 'reverse (-tails (nreverse list))))) |
|
2304 |
|
|
2305 |
(defun -tails (list) |
|
2306 |
"Return all suffixes of LIST" |
|
2307 |
(-reductions-r-from 'cons nil list)) |
|
2308 |
|
|
2309 |
(defun -common-prefix (&rest lists) |
|
2310 |
"Return the longest common prefix of LISTS." |
|
2311 |
(declare (pure t) (side-effect-free t)) |
|
2312 |
(--reduce (--take-while (and acc (equal (pop acc) it)) it) |
|
2313 |
lists)) |
|
2314 |
|
|
2315 |
(defun -common-suffix (&rest lists) |
|
2316 |
"Return the longest common suffix of LISTS." |
|
2317 |
(nreverse (apply #'-common-prefix (mapcar #'reverse lists)))) |
|
2318 |
|
|
2319 |
(defun -contains? (list element) |
|
2320 |
"Return non-nil if LIST contains ELEMENT. |
|
2321 |
|
|
2322 |
The test for equality is done with `equal', or with `-compare-fn' |
|
2323 |
if that's non-nil. |
|
2324 |
|
|
2325 |
Alias: `-contains-p'" |
|
2326 |
(not |
|
2327 |
(null |
|
2328 |
(cond |
|
2329 |
((null -compare-fn) (member element list)) |
|
2330 |
((eq -compare-fn 'eq) (memq element list)) |
|
2331 |
((eq -compare-fn 'eql) (memql element list)) |
|
2332 |
(t |
|
2333 |
(let ((lst list)) |
|
2334 |
(while (and lst |
|
2335 |
(not (funcall -compare-fn element (car lst)))) |
|
2336 |
(setq lst (cdr lst))) |
|
2337 |
lst)))))) |
|
2338 |
|
|
2339 |
(defalias '-contains-p '-contains?) |
|
2340 |
|
|
2341 |
(defun -same-items? (list list2) |
|
2342 |
"Return true if LIST and LIST2 has the same items. |
|
2343 |
|
|
2344 |
The order of the elements in the lists does not matter. |
|
2345 |
|
|
2346 |
Alias: `-same-items-p'" |
|
2347 |
(let ((length-a (length list)) |
|
2348 |
(length-b (length list2))) |
|
2349 |
(and |
|
2350 |
(= length-a length-b) |
|
2351 |
(= length-a (length (-intersection list list2)))))) |
|
2352 |
|
|
2353 |
(defalias '-same-items-p '-same-items?) |
|
2354 |
|
|
2355 |
(defun -is-prefix? (prefix list) |
|
2356 |
"Return non-nil if PREFIX is prefix of LIST. |
|
2357 |
|
|
2358 |
Alias: `-is-prefix-p'" |
|
2359 |
(declare (pure t) (side-effect-free t)) |
|
2360 |
(--each-while list (equal (car prefix) it) |
|
2361 |
(!cdr prefix)) |
|
2362 |
(not prefix)) |
|
2363 |
|
|
2364 |
(defun -is-suffix? (suffix list) |
|
2365 |
"Return non-nil if SUFFIX is suffix of LIST. |
|
2366 |
|
|
2367 |
Alias: `-is-suffix-p'" |
|
2368 |
(declare (pure t) (side-effect-free t)) |
|
2369 |
(-is-prefix? (reverse suffix) (reverse list))) |
|
2370 |
|
|
2371 |
(defun -is-infix? (infix list) |
|
2372 |
"Return non-nil if INFIX is infix of LIST. |
|
2373 |
|
|
2374 |
This operation runs in O(n^2) time |
|
2375 |
|
|
2376 |
Alias: `-is-infix-p'" |
|
2377 |
(declare (pure t) (side-effect-free t)) |
|
2378 |
(let (done) |
|
2379 |
(while (and (not done) list) |
|
2380 |
(setq done (-is-prefix? infix list)) |
|
2381 |
(!cdr list)) |
|
2382 |
done)) |
|
2383 |
|
|
2384 |
(defalias '-is-prefix-p '-is-prefix?) |
|
2385 |
(defalias '-is-suffix-p '-is-suffix?) |
|
2386 |
(defalias '-is-infix-p '-is-infix?) |
|
2387 |
|
|
2388 |
(defun -sort (comparator list) |
|
2389 |
"Sort LIST, stably, comparing elements using COMPARATOR. |
|
2390 |
Return the sorted list. LIST is NOT modified by side effects. |
|
2391 |
COMPARATOR is called with two elements of LIST, and should return non-nil |
|
2392 |
if the first element should sort before the second." |
|
2393 |
(sort (copy-sequence list) comparator)) |
|
2394 |
|
|
2395 |
(defmacro --sort (form list) |
|
2396 |
"Anaphoric form of `-sort'." |
|
2397 |
(declare (debug (form form))) |
|
2398 |
`(-sort (lambda (it other) ,form) ,list)) |
|
2399 |
|
|
2400 |
(defun -list (&rest args) |
|
2401 |
"Return a list with ARGS. |
|
2402 |
|
|
2403 |
If first item of ARGS is already a list, simply return ARGS. If |
|
2404 |
not, return a list with ARGS as elements." |
|
2405 |
(declare (pure t) (side-effect-free t)) |
|
2406 |
(let ((arg (car args))) |
|
2407 |
(if (listp arg) arg args))) |
|
2408 |
|
|
2409 |
(defun -repeat (n x) |
|
2410 |
"Return a list with X repeated N times. |
|
2411 |
Return nil if N is less than 1." |
|
2412 |
(declare (pure t) (side-effect-free t)) |
|
2413 |
(let (ret) |
|
2414 |
(--dotimes n (!cons x ret)) |
|
2415 |
ret)) |
|
2416 |
|
|
2417 |
(defun -sum (list) |
|
2418 |
"Return the sum of LIST." |
|
2419 |
(declare (pure t) (side-effect-free t)) |
|
2420 |
(apply '+ list)) |
|
2421 |
|
|
2422 |
(defun -running-sum (list) |
|
2423 |
"Return a list with running sums of items in LIST. |
|
2424 |
|
|
2425 |
LIST must be non-empty." |
|
2426 |
(declare (pure t) (side-effect-free t)) |
|
2427 |
(unless (consp list) |
|
2428 |
(error "LIST must be non-empty")) |
|
2429 |
(-reductions '+ list)) |
|
2430 |
|
|
2431 |
(defun -product (list) |
|
2432 |
"Return the product of LIST." |
|
2433 |
(declare (pure t) (side-effect-free t)) |
|
2434 |
(apply '* list)) |
|
2435 |
|
|
2436 |
(defun -running-product (list) |
|
2437 |
"Return a list with running products of items in LIST. |
|
2438 |
|
|
2439 |
LIST must be non-empty." |
|
2440 |
(declare (pure t) (side-effect-free t)) |
|
2441 |
(unless (consp list) |
|
2442 |
(error "LIST must be non-empty")) |
|
2443 |
(-reductions '* list)) |
|
2444 |
|
|
2445 |
(defun -max (list) |
|
2446 |
"Return the largest value from LIST of numbers or markers." |
|
2447 |
(declare (pure t) (side-effect-free t)) |
|
2448 |
(apply 'max list)) |
|
2449 |
|
|
2450 |
(defun -min (list) |
|
2451 |
"Return the smallest value from LIST of numbers or markers." |
|
2452 |
(declare (pure t) (side-effect-free t)) |
|
2453 |
(apply 'min list)) |
|
2454 |
|
|
2455 |
(defun -max-by (comparator list) |
|
2456 |
"Take a comparison function COMPARATOR and a LIST and return |
|
2457 |
the greatest element of the list by the comparison function. |
|
2458 |
|
|
2459 |
See also combinator `-on' which can transform the values before |
|
2460 |
comparing them." |
|
2461 |
(--reduce (if (funcall comparator it acc) it acc) list)) |
|
2462 |
|
|
2463 |
(defun -min-by (comparator list) |
|
2464 |
"Take a comparison function COMPARATOR and a LIST and return |
|
2465 |
the least element of the list by the comparison function. |
|
2466 |
|
|
2467 |
See also combinator `-on' which can transform the values before |
|
2468 |
comparing them." |
|
2469 |
(--reduce (if (funcall comparator it acc) acc it) list)) |
|
2470 |
|
|
2471 |
(defmacro --max-by (form list) |
|
2472 |
"Anaphoric version of `-max-by'. |
|
2473 |
|
|
2474 |
The items for the comparator form are exposed as \"it\" and \"other\"." |
|
2475 |
(declare (debug (form form))) |
|
2476 |
`(-max-by (lambda (it other) ,form) ,list)) |
|
2477 |
|
|
2478 |
(defmacro --min-by (form list) |
|
2479 |
"Anaphoric version of `-min-by'. |
|
2480 |
|
|
2481 |
The items for the comparator form are exposed as \"it\" and \"other\"." |
|
2482 |
(declare (debug (form form))) |
|
2483 |
`(-min-by (lambda (it other) ,form) ,list)) |
|
2484 |
|
|
2485 |
(defun -iterate (fun init n) |
|
2486 |
"Return a list of iterated applications of FUN to INIT. |
|
2487 |
|
|
2488 |
This means a list of form: |
|
2489 |
|
|
2490 |
(init (fun init) (fun (fun init)) ...) |
|
2491 |
|
|
2492 |
N is the length of the returned list." |
|
2493 |
(if (= n 0) nil |
|
2494 |
(let ((r (list init))) |
|
2495 |
(--dotimes (1- n) |
|
2496 |
(push (funcall fun (car r)) r)) |
|
2497 |
(nreverse r)))) |
|
2498 |
|
|
2499 |
(defun -fix (fn list) |
|
2500 |
"Compute the (least) fixpoint of FN with initial input LIST. |
|
2501 |
|
|
2502 |
FN is called at least once, results are compared with `equal'." |
|
2503 |
(let ((re (funcall fn list))) |
|
2504 |
(while (not (equal list re)) |
|
2505 |
(setq list re) |
|
2506 |
(setq re (funcall fn re))) |
|
2507 |
re)) |
|
2508 |
|
|
2509 |
(defmacro --fix (form list) |
|
2510 |
"Anaphoric form of `-fix'." |
|
2511 |
`(-fix (lambda (it) ,form) ,list)) |
|
2512 |
|
|
2513 |
(defun -unfold (fun seed) |
|
2514 |
"Build a list from SEED using FUN. |
|
2515 |
|
|
2516 |
This is \"dual\" operation to `-reduce-r': while -reduce-r |
|
2517 |
consumes a list to produce a single value, `-unfold' takes a |
|
2518 |
seed value and builds a (potentially infinite!) list. |
|
2519 |
|
|
2520 |
FUN should return `nil' to stop the generating process, or a |
|
2521 |
cons (A . B), where A will be prepended to the result and B is |
|
2522 |
the new seed." |
|
2523 |
(let ((last (funcall fun seed)) r) |
|
2524 |
(while last |
|
2525 |
(push (car last) r) |
|
2526 |
(setq last (funcall fun (cdr last)))) |
|
2527 |
(nreverse r))) |
|
2528 |
|
|
2529 |
(defmacro --unfold (form seed) |
|
2530 |
"Anaphoric version of `-unfold'." |
|
2531 |
(declare (debug (form form))) |
|
2532 |
`(-unfold (lambda (it) ,form) ,seed)) |
|
2533 |
|
|
2534 |
(defun -cons-pair? (con) |
|
2535 |
"Return non-nil if CON is true cons pair. |
|
2536 |
That is (A . B) where B is not a list." |
|
2537 |
(declare (pure t) (side-effect-free t)) |
|
2538 |
(and (listp con) |
|
2539 |
(not (listp (cdr con))))) |
|
2540 |
|
|
2541 |
(defun -cons-to-list (con) |
|
2542 |
"Convert a cons pair to a list with `car' and `cdr' of the pair respectively." |
|
2543 |
(declare (pure t) (side-effect-free t)) |
|
2544 |
(list (car con) (cdr con))) |
|
2545 |
|
|
2546 |
(defun -value-to-list (val) |
|
2547 |
"Convert a value to a list. |
|
2548 |
|
|
2549 |
If the value is a cons pair, make a list with two elements, `car' |
|
2550 |
and `cdr' of the pair respectively. |
|
2551 |
|
|
2552 |
If the value is anything else, wrap it in a list." |
|
2553 |
(declare (pure t) (side-effect-free t)) |
|
2554 |
(cond |
|
2555 |
((-cons-pair? val) (-cons-to-list val)) |
|
2556 |
(t (list val)))) |
|
2557 |
|
|
2558 |
(defun -tree-mapreduce-from (fn folder init-value tree) |
|
2559 |
"Apply FN to each element of TREE, and make a list of the results. |
|
2560 |
If elements of TREE are lists themselves, apply FN recursively to |
|
2561 |
elements of these nested lists. |
|
2562 |
|
|
2563 |
Then reduce the resulting lists using FOLDER and initial value |
|
2564 |
INIT-VALUE. See `-reduce-r-from'. |
|
2565 |
|
|
2566 |
This is the same as calling `-tree-reduce-from' after `-tree-map' |
|
2567 |
but is twice as fast as it only traverse the structure once." |
|
2568 |
(cond |
|
2569 |
((not tree) nil) |
|
2570 |
((-cons-pair? tree) (funcall fn tree)) |
|
2571 |
((listp tree) |
|
2572 |
(-reduce-r-from folder init-value (mapcar (lambda (x) (-tree-mapreduce-from fn folder init-value x)) tree))) |
|
2573 |
(t (funcall fn tree)))) |
|
2574 |
|
|
2575 |
(defmacro --tree-mapreduce-from (form folder init-value tree) |
|
2576 |
"Anaphoric form of `-tree-mapreduce-from'." |
|
2577 |
(declare (debug (form form form form))) |
|
2578 |
`(-tree-mapreduce-from (lambda (it) ,form) (lambda (it acc) ,folder) ,init-value ,tree)) |
|
2579 |
|
|
2580 |
(defun -tree-mapreduce (fn folder tree) |
|
2581 |
"Apply FN to each element of TREE, and make a list of the results. |
|
2582 |
If elements of TREE are lists themselves, apply FN recursively to |
|
2583 |
elements of these nested lists. |
|
2584 |
|
|
2585 |
Then reduce the resulting lists using FOLDER and initial value |
|
2586 |
INIT-VALUE. See `-reduce-r-from'. |
|
2587 |
|
|
2588 |
This is the same as calling `-tree-reduce' after `-tree-map' |
|
2589 |
but is twice as fast as it only traverse the structure once." |
|
2590 |
(cond |
|
2591 |
((not tree) nil) |
|
2592 |
((-cons-pair? tree) (funcall fn tree)) |
|
2593 |
((listp tree) |
|
2594 |
(-reduce-r folder (mapcar (lambda (x) (-tree-mapreduce fn folder x)) tree))) |
|
2595 |
(t (funcall fn tree)))) |
|
2596 |
|
|
2597 |
(defmacro --tree-mapreduce (form folder tree) |
|
2598 |
"Anaphoric form of `-tree-mapreduce'." |
|
2599 |
(declare (debug (form form form))) |
|
2600 |
`(-tree-mapreduce (lambda (it) ,form) (lambda (it acc) ,folder) ,tree)) |
|
2601 |
|
|
2602 |
(defun -tree-map (fn tree) |
|
2603 |
"Apply FN to each element of TREE while preserving the tree structure." |
|
2604 |
(cond |
|
2605 |
((not tree) nil) |
|
2606 |
((-cons-pair? tree) (funcall fn tree)) |
|
2607 |
((listp tree) |
|
2608 |
(mapcar (lambda (x) (-tree-map fn x)) tree)) |
|
2609 |
(t (funcall fn tree)))) |
|
2610 |
|
|
2611 |
(defmacro --tree-map (form tree) |
|
2612 |
"Anaphoric form of `-tree-map'." |
|
2613 |
(declare (debug (form form))) |
|
2614 |
`(-tree-map (lambda (it) ,form) ,tree)) |
|
2615 |
|
|
2616 |
(defun -tree-reduce-from (fn init-value tree) |
|
2617 |
"Use FN to reduce elements of list TREE. |
|
2618 |
If elements of TREE are lists themselves, apply the reduction recursively. |
|
2619 |
|
|
2620 |
FN is first applied to INIT-VALUE and first element of the list, |
|
2621 |
then on this result and second element from the list etc. |
|
2622 |
|
|
2623 |
The initial value is ignored on cons pairs as they always contain |
|
2624 |
two elements." |
|
2625 |
(cond |
|
2626 |
((not tree) nil) |
|
2627 |
((-cons-pair? tree) tree) |
|
2628 |
((listp tree) |
|
2629 |
(-reduce-r-from fn init-value (mapcar (lambda (x) (-tree-reduce-from fn init-value x)) tree))) |
|
2630 |
(t tree))) |
|
2631 |
|
|
2632 |
(defmacro --tree-reduce-from (form init-value tree) |
|
2633 |
"Anaphoric form of `-tree-reduce-from'." |
|
2634 |
(declare (debug (form form form))) |
|
2635 |
`(-tree-reduce-from (lambda (it acc) ,form) ,init-value ,tree)) |
|
2636 |
|
|
2637 |
(defun -tree-reduce (fn tree) |
|
2638 |
"Use FN to reduce elements of list TREE. |
|
2639 |
If elements of TREE are lists themselves, apply the reduction recursively. |
|
2640 |
|
|
2641 |
FN is first applied to first element of the list and second |
|
2642 |
element, then on this result and third element from the list etc. |
|
2643 |
|
|
2644 |
See `-reduce-r' for how exactly are lists of zero or one element handled." |
|
2645 |
(cond |
|
2646 |
((not tree) nil) |
|
2647 |
((-cons-pair? tree) tree) |
|
2648 |
((listp tree) |
|
2649 |
(-reduce-r fn (mapcar (lambda (x) (-tree-reduce fn x)) tree))) |
|
2650 |
(t tree))) |
|
2651 |
|
|
2652 |
(defmacro --tree-reduce (form tree) |
|
2653 |
"Anaphoric form of `-tree-reduce'." |
|
2654 |
(declare (debug (form form))) |
|
2655 |
`(-tree-reduce (lambda (it acc) ,form) ,tree)) |
|
2656 |
|
|
2657 |
(defun -tree-map-nodes (pred fun tree) |
|
2658 |
"Call FUN on each node of TREE that satisfies PRED. |
|
2659 |
|
|
2660 |
If PRED returns nil, continue descending down this node. If PRED |
|
2661 |
returns non-nil, apply FUN to this node and do not descend |
|
2662 |
further." |
|
2663 |
(if (funcall pred tree) |
|
2664 |
(funcall fun tree) |
|
2665 |
(if (and (listp tree) |
|
2666 |
(not (-cons-pair? tree))) |
|
2667 |
(-map (lambda (x) (-tree-map-nodes pred fun x)) tree) |
|
2668 |
tree))) |
|
2669 |
|
|
2670 |
(defmacro --tree-map-nodes (pred form tree) |
|
2671 |
"Anaphoric form of `-tree-map-nodes'." |
|
2672 |
`(-tree-map-nodes (lambda (it) ,pred) (lambda (it) ,form) ,tree)) |
|
2673 |
|
|
2674 |
(defun -tree-seq (branch children tree) |
|
2675 |
"Return a sequence of the nodes in TREE, in depth-first search order. |
|
2676 |
|
|
2677 |
BRANCH is a predicate of one argument that returns non-nil if the |
|
2678 |
passed argument is a branch, that is, a node that can have children. |
|
2679 |
|
|
2680 |
CHILDREN is a function of one argument that returns the children |
|
2681 |
of the passed branch node. |
|
2682 |
|
|
2683 |
Non-branch nodes are simply copied." |
|
2684 |
(cons tree |
|
2685 |
(when (funcall branch tree) |
|
2686 |
(-mapcat (lambda (x) (-tree-seq branch children x)) |
|
2687 |
(funcall children tree))))) |
|
2688 |
|
|
2689 |
(defmacro --tree-seq (branch children tree) |
|
2690 |
"Anaphoric form of `-tree-seq'." |
|
2691 |
`(-tree-seq (lambda (it) ,branch) (lambda (it) ,children) ,tree)) |
|
2692 |
|
|
2693 |
(defun -clone (list) |
|
2694 |
"Create a deep copy of LIST. |
|
2695 |
The new list has the same elements and structure but all cons are |
|
2696 |
replaced with new ones. This is useful when you need to clone a |
|
2697 |
structure such as plist or alist." |
|
2698 |
(declare (pure t) (side-effect-free t)) |
|
2699 |
(-tree-map 'identity list)) |
|
2700 |
|
|
2701 |
(defun dash-enable-font-lock () |
|
2702 |
"Add syntax highlighting to dash functions, macros and magic values." |
|
2703 |
(eval-after-load 'lisp-mode |
|
2704 |
'(progn |
|
2705 |
(let ((new-keywords '( |
|
2706 |
"!cons" |
|
2707 |
"!cdr" |
|
2708 |
"-each" |
|
2709 |
"--each" |
|
2710 |
"-each-indexed" |
|
2711 |
"--each-indexed" |
|
2712 |
"-each-while" |
|
2713 |
"--each-while" |
|
2714 |
"-doto" |
|
2715 |
"-dotimes" |
|
2716 |
"--dotimes" |
|
2717 |
"-map" |
|
2718 |
"--map" |
|
2719 |
"-reduce-from" |
|
2720 |
"--reduce-from" |
|
2721 |
"-reduce" |
|
2722 |
"--reduce" |
|
2723 |
"-reduce-r-from" |
|
2724 |
"--reduce-r-from" |
|
2725 |
"-reduce-r" |
|
2726 |
"--reduce-r" |
|
2727 |
"-reductions-from" |
|
2728 |
"-reductions-r-from" |
|
2729 |
"-reductions" |
|
2730 |
"-reductions-r" |
|
2731 |
"-filter" |
|
2732 |
"--filter" |
|
2733 |
"-select" |
|
2734 |
"--select" |
|
2735 |
"-remove" |
|
2736 |
"--remove" |
|
2737 |
"-reject" |
|
2738 |
"--reject" |
|
2739 |
"-remove-first" |
|
2740 |
"--remove-first" |
|
2741 |
"-reject-first" |
|
2742 |
"--reject-first" |
|
2743 |
"-remove-last" |
|
2744 |
"--remove-last" |
|
2745 |
"-reject-last" |
|
2746 |
"--reject-last" |
|
2747 |
"-remove-item" |
|
2748 |
"-non-nil" |
|
2749 |
"-keep" |
|
2750 |
"--keep" |
|
2751 |
"-map-indexed" |
|
2752 |
"--map-indexed" |
|
2753 |
"-splice" |
|
2754 |
"--splice" |
|
2755 |
"-splice-list" |
|
2756 |
"--splice-list" |
|
2757 |
"-map-when" |
|
2758 |
"--map-when" |
|
2759 |
"-replace-where" |
|
2760 |
"--replace-where" |
|
2761 |
"-map-first" |
|
2762 |
"--map-first" |
|
2763 |
"-map-last" |
|
2764 |
"--map-last" |
|
2765 |
"-replace" |
|
2766 |
"-replace-first" |
|
2767 |
"-replace-last" |
|
2768 |
"-flatten" |
|
2769 |
"-flatten-n" |
|
2770 |
"-concat" |
|
2771 |
"-mapcat" |
|
2772 |
"--mapcat" |
|
2773 |
"-copy" |
|
2774 |
"-cons*" |
|
2775 |
"-snoc" |
|
2776 |
"-first" |
|
2777 |
"--first" |
|
2778 |
"-find" |
|
2779 |
"--find" |
|
2780 |
"-some" |
|
2781 |
"--some" |
|
2782 |
"-any" |
|
2783 |
"--any" |
|
2784 |
"-last" |
|
2785 |
"--last" |
|
2786 |
"-first-item" |
|
2787 |
"-second-item" |
|
2788 |
"-third-item" |
|
2789 |
"-fourth-item" |
|
2790 |
"-fifth-item" |
|
2791 |
"-last-item" |
|
2792 |
"-butlast" |
|
2793 |
"-count" |
|
2794 |
"--count" |
|
2795 |
"-any?" |
|
2796 |
"--any?" |
|
2797 |
"-some?" |
|
2798 |
"--some?" |
|
2799 |
"-any-p" |
|
2800 |
"--any-p" |
|
2801 |
"-some-p" |
|
2802 |
"--some-p" |
|
2803 |
"-some->" |
|
2804 |
"-some->>" |
|
2805 |
"-some-->" |
|
2806 |
"-all?" |
|
2807 |
"-all-p" |
|
2808 |
"--all?" |
|
2809 |
"--all-p" |
|
2810 |
"-every?" |
|
2811 |
"--every?" |
|
2812 |
"-all-p" |
|
2813 |
"--all-p" |
|
2814 |
"-every-p" |
|
2815 |
"--every-p" |
|
2816 |
"-none?" |
|
2817 |
"--none?" |
|
2818 |
"-none-p" |
|
2819 |
"--none-p" |
|
2820 |
"-only-some?" |
|
2821 |
"--only-some?" |
|
2822 |
"-only-some-p" |
|
2823 |
"--only-some-p" |
|
2824 |
"-slice" |
|
2825 |
"-take" |
|
2826 |
"-drop" |
|
2827 |
"-drop-last" |
|
2828 |
"-take-last" |
|
2829 |
"-take-while" |
|
2830 |
"--take-while" |
|
2831 |
"-drop-while" |
|
2832 |
"--drop-while" |
|
2833 |
"-split-at" |
|
2834 |
"-rotate" |
|
2835 |
"-insert-at" |
|
2836 |
"-replace-at" |
|
2837 |
"-update-at" |
|
2838 |
"--update-at" |
|
2839 |
"-remove-at" |
|
2840 |
"-remove-at-indices" |
|
2841 |
"-split-with" |
|
2842 |
"--split-with" |
|
2843 |
"-split-on" |
|
2844 |
"-split-when" |
|
2845 |
"--split-when" |
|
2846 |
"-separate" |
|
2847 |
"--separate" |
|
2848 |
"-partition-all-in-steps" |
|
2849 |
"-partition-in-steps" |
|
2850 |
"-partition-all" |
|
2851 |
"-partition" |
|
2852 |
"-partition-after-item" |
|
2853 |
"-partition-after-pred" |
|
2854 |
"-partition-before-item" |
|
2855 |
"-partition-before-pred" |
|
2856 |
"-partition-by" |
|
2857 |
"--partition-by" |
|
2858 |
"-partition-by-header" |
|
2859 |
"--partition-by-header" |
|
2860 |
"-group-by" |
|
2861 |
"--group-by" |
|
2862 |
"-interpose" |
|
2863 |
"-interleave" |
|
2864 |
"-unzip" |
|
2865 |
"-zip-with" |
|
2866 |
"--zip-with" |
|
2867 |
"-zip" |
|
2868 |
"-zip-fill" |
|
2869 |
"-zip-pair" |
|
2870 |
"-cycle" |
|
2871 |
"-pad" |
|
2872 |
"-annotate" |
|
2873 |
"--annotate" |
|
2874 |
"-table" |
|
2875 |
"-table-flat" |
|
2876 |
"-partial" |
|
2877 |
"-elem-index" |
|
2878 |
"-elem-indices" |
|
2879 |
"-find-indices" |
|
2880 |
"--find-indices" |
|
2881 |
"-find-index" |
|
2882 |
"--find-index" |
|
2883 |
"-find-last-index" |
|
2884 |
"--find-last-index" |
|
2885 |
"-select-by-indices" |
|
2886 |
"-select-columns" |
|
2887 |
"-select-column" |
|
2888 |
"-grade-up" |
|
2889 |
"-grade-down" |
|
2890 |
"->" |
|
2891 |
"->>" |
|
2892 |
"-->" |
|
2893 |
"-as->" |
|
2894 |
"-when-let" |
|
2895 |
"-when-let*" |
|
2896 |
"--when-let" |
|
2897 |
"-if-let" |
|
2898 |
"-if-let*" |
|
2899 |
"--if-let" |
|
2900 |
"-let*" |
|
2901 |
"-let" |
|
2902 |
"-lambda" |
|
2903 |
"-distinct" |
|
2904 |
"-uniq" |
|
2905 |
"-union" |
|
2906 |
"-intersection" |
|
2907 |
"-difference" |
|
2908 |
"-powerset" |
|
2909 |
"-permutations" |
|
2910 |
"-inits" |
|
2911 |
"-tails" |
|
2912 |
"-common-prefix" |
|
2913 |
"-common-suffix" |
|
2914 |
"-contains?" |
|
2915 |
"-contains-p" |
|
2916 |
"-same-items?" |
|
2917 |
"-same-items-p" |
|
2918 |
"-is-prefix-p" |
|
2919 |
"-is-prefix?" |
|
2920 |
"-is-suffix-p" |
|
2921 |
"-is-suffix?" |
|
2922 |
"-is-infix-p" |
|
2923 |
"-is-infix?" |
|
2924 |
"-sort" |
|
2925 |
"--sort" |
|
2926 |
"-list" |
|
2927 |
"-repeat" |
|
2928 |
"-sum" |
|
2929 |
"-running-sum" |
|
2930 |
"-product" |
|
2931 |
"-running-product" |
|
2932 |
"-max" |
|
2933 |
"-min" |
|
2934 |
"-max-by" |
|
2935 |
"--max-by" |
|
2936 |
"-min-by" |
|
2937 |
"--min-by" |
|
2938 |
"-iterate" |
|
2939 |
"--iterate" |
|
2940 |
"-fix" |
|
2941 |
"--fix" |
|
2942 |
"-unfold" |
|
2943 |
"--unfold" |
|
2944 |
"-cons-pair?" |
|
2945 |
"-cons-to-list" |
|
2946 |
"-value-to-list" |
|
2947 |
"-tree-mapreduce-from" |
|
2948 |
"--tree-mapreduce-from" |
|
2949 |
"-tree-mapreduce" |
|
2950 |
"--tree-mapreduce" |
|
2951 |
"-tree-map" |
|
2952 |
"--tree-map" |
|
2953 |
"-tree-reduce-from" |
|
2954 |
"--tree-reduce-from" |
|
2955 |
"-tree-reduce" |
|
2956 |
"--tree-reduce" |
|
2957 |
"-tree-seq" |
|
2958 |
"--tree-seq" |
|
2959 |
"-tree-map-nodes" |
|
2960 |
"--tree-map-nodes" |
|
2961 |
"-clone" |
|
2962 |
"-rpartial" |
|
2963 |
"-juxt" |
|
2964 |
"-applify" |
|
2965 |
"-on" |
|
2966 |
"-flip" |
|
2967 |
"-const" |
|
2968 |
"-cut" |
|
2969 |
"-orfn" |
|
2970 |
"-andfn" |
|
2971 |
"-iteratefn" |
|
2972 |
"-fixfn" |
|
2973 |
"-prodfn" |
|
2974 |
)) |
|
2975 |
(special-variables '( |
|
2976 |
"it" |
|
2977 |
"it-index" |
|
2978 |
"acc" |
|
2979 |
"other" |
|
2980 |
))) |
|
2981 |
(font-lock-add-keywords 'emacs-lisp-mode `((,(concat "\\_<" (regexp-opt special-variables 'paren) "\\_>") |
|
2982 |
1 font-lock-variable-name-face)) 'append) |
|
2983 |
(font-lock-add-keywords 'emacs-lisp-mode `((,(concat "(\\s-*" (regexp-opt new-keywords 'paren) "\\_>") |
|
2984 |
1 font-lock-keyword-face)) 'append)) |
|
2985 |
(--each (buffer-list) |
|
2986 |
(with-current-buffer it |
|
2987 |
(when (and (eq major-mode 'emacs-lisp-mode) |
|
2988 |
(boundp 'font-lock-mode) |
|
2989 |
font-lock-mode) |
|
2990 |
(font-lock-refresh-defaults))))))) |
|
2991 |
|
|
2992 |
(provide 'dash) |
|
2993 |
;;; dash.el ends here |