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