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