test/lisp/emacs-lisp/subr-x-tests.el

   1 ;;; subr-x-tests.el --- Testing the extended lisp routines
   2
   3 ;; Copyright (C) 2014-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Fabián E. Gallina <fgallina@gnu.org>
   6 ;; Keywords:
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;
  24
  25 ;;; Code:
  26
  27 (require 'ert)
  28 (require 'subr-x)
  29
  30 \f
  31 ;; `if-let*' tests
  32
  33 (ert-deftest subr-x-test-if-let*-single-binding-expansion ()
  34   "Test single bindings are expanded properly."
  35   (should (equal
  36            (macroexpand
  37             '(if-let* ((a 1))
  38                  (- a)
  39                "no"))
  40            '(let* ((a (and t 1)))
  41               (if a
  42                   (- a)
  43                 "no"))))
  44   (should (equal
  45            (macroexpand
  46             '(if-let* (a)
  47                  (- a)
  48                "no"))
  49            '(let* ((a (and t a)))
  50               (if a
  51                   (- a)
  52                 "no")))))
  53
  54 (ert-deftest subr-x-test-if-let*-single-symbol-expansion ()
  55   "Test single symbol bindings are expanded properly."
  56   (should (equal
  57            (macroexpand
  58             '(if-let* (a)
  59                  (- a)
  60                "no"))
  61            '(let* ((a (and t a)))
  62               (if a
  63                   (- a)
  64                 "no"))))
  65   (should (equal
  66            (macroexpand
  67             '(if-let* (a b c)
  68                  (- a)
  69                "no"))
  70            '(let* ((a (and t a))
  71                    (b (and a b))
  72                    (c (and b c)))
  73               (if c
  74                   (- a)
  75                 "no"))))
  76   (should (equal
  77            (macroexpand
  78             '(if-let* (a (b 2) c)
  79                  (- a)
  80                "no"))
  81            '(let* ((a (and t a))
  82                    (b (and a 2))
  83                    (c (and b c)))
  84               (if c
  85                   (- a)
  86                 "no")))))
  87
  88 (ert-deftest subr-x-test-if-let*-nil-related-expansion ()
  89   "Test nil is processed properly."
  90   (should (equal
  91            (macroexpand
  92             '(if-let* (nil)
  93                  (- a)
  94                "no"))
  95            '(let* ((nil (and t nil)))
  96               (if nil
  97                   (- a)
  98                 "no"))))
  99   (should (equal
 100            (macroexpand
 101             '(if-let* ((a 1) nil (b 2))
 102                  (- a)
 103                "no"))
 104            '(let* ((a (and t 1))
 105                    (nil (and a nil))
 106                    (b (and nil 2)))
 107               (if b
 108                   (- a)
 109                 "no")))))
 110
 111 (ert-deftest subr-x-test-if-let*-malformed-binding ()
 112   "Test malformed bindings trigger errors."
 113   (should-error (macroexpand
 114                  '(if-let* (_ (a 1 1) (b 2) (c 3) d)
 115                       (- a)
 116                     "no"))
 117                 :type 'error)
 118   (should-error (macroexpand
 119                  '(if-let* (_ (a 1) (b 2 2) (c 3) d)
 120                       (- a)
 121                     "no"))
 122                 :type 'error)
 123   (should-error (macroexpand
 124                  '(if-let* (_ (a 1) (b 2) (c 3 3) d)
 125                       (- a)
 126                     "no"))
 127                 :type 'error)
 128   (should-error (macroexpand
 129                  '(if-let* ((a 1 1))
 130                       (- a)
 131                     "no"))
 132                 :type 'error))
 133
 134 (ert-deftest subr-x-test-if-let*-true ()
 135   "Test `if-let' with truthy bindings."
 136   (should (equal
 137            (if-let* ((a 1))
 138                a
 139              "no")
 140            1))
 141   (should (equal
 142            (if-let* ((a 1) (b 2) (c 3))
 143                (list a b c)
 144              "no")
 145            (list 1 2 3))))
 146
 147 (ert-deftest subr-x-test-if-let*-false ()
 148   "Test `if-let' with falsie bindings."
 149   (should (equal
 150            (if-let* ((a nil))
 151                "yes"
 152              "no")
 153            "no"))
 154   (should (equal
 155            (if-let* ((a nil) (b 2) (c 3))
 156                "yes"
 157              "no")
 158            "no"))
 159   (should (equal
 160            (if-let* ((a 1) (b nil) (c 3))
 161                "yes"
 162              "no")
 163            "no"))
 164   (should (equal
 165            (if-let* ((a 1) (b 2) (c nil))
 166                "yes"
 167              "no")
 168            "no"))
 169   (should (equal
 170            (let (z)
 171              (if-let* (z (a 1) (b 2) (c 3))
 172                  "yes"
 173                "no"))
 174            "no"))
 175   (should (equal
 176            (let (d)
 177              (if-let* ((a 1) (b 2) (c 3) d)
 178                  "yes"
 179                "no"))
 180            "no")))
 181
 182 (ert-deftest subr-x-test-if-let*-bound-references ()
 183   "Test `if-let' bindings can refer to already bound symbols."
 184   (should (equal
 185            (if-let* ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
 186                (list a b c)
 187              "no")
 188            (list 1 2 3))))
 189
 190 (ert-deftest subr-x-test-if-let*-and-laziness-is-preserved ()
 191   "Test `if-let' respects `and' laziness."
 192   (let (a-called b-called c-called)
 193     (should (equal
 194              (if-let* ((a nil)
 195                        (b (setq b-called t))
 196                        (c (setq c-called t)))
 197                  "yes"
 198                (list a-called b-called c-called))
 199              (list nil nil nil))))
 200   (let (a-called b-called c-called)
 201     (should (equal
 202              (if-let* ((a (setq a-called t))
 203                        (b nil)
 204                        (c (setq c-called t)))
 205                  "yes"
 206                (list a-called b-called c-called))
 207              (list t nil nil))))
 208   (let (a-called b-called c-called)
 209     (should (equal
 210              (if-let* ((a (setq a-called t))
 211                       (b (setq b-called t))
 212                       (c nil)
 213                       (d (setq c-called t)))
 214                  "yes"
 215                (list a-called b-called c-called))
 216              (list t t nil)))))
 217
 218 \f
 219 ;; `when-let*' tests
 220
 221 (ert-deftest subr-x-test-when-let*-body-expansion ()
 222   "Test body allows for multiple sexps wrapping with progn."
 223   (should (equal
 224            (macroexpand
 225             '(when-let* ((a 1))
 226                (message "opposite")
 227                (- a)))
 228            '(let* ((a (and t 1)))
 229               (if a
 230                   (progn
 231                     (message "opposite")
 232                     (- a)))))))
 233
 234 (ert-deftest subr-x-test-when-let*-single-symbol-expansion ()
 235   "Test single symbol bindings are expanded properly."
 236   (should (equal
 237            (macroexpand
 238             '(when-let* (a)
 239                (- a)))
 240            '(let* ((a (and t a)))
 241               (if a
 242                   (- a)))))
 243   (should (equal
 244            (macroexpand
 245             '(when-let* (a b c)
 246                (- a)))
 247            '(let* ((a (and t a))
 248                    (b (and a b))
 249                    (c (and b c)))
 250               (if c
 251                   (- a)))))
 252   (should (equal
 253            (macroexpand
 254             '(when-let* (a (b 2) c)
 255                (- a)))
 256            '(let* ((a (and t a))
 257                    (b (and a 2))
 258                    (c (and b c)))
 259               (if c
 260                   (- a))))))
 261
 262 (ert-deftest subr-x-test-when-let*-nil-related-expansion ()
 263   "Test nil is processed properly."
 264   (should (equal
 265            (macroexpand
 266             '(when-let* (nil)
 267                (- a)))
 268            '(let* ((nil (and t nil)))
 269               (if nil
 270                   (- a)))))
 271   (should (equal
 272            (macroexpand
 273             '(when-let* ((a 1) nil (b 2))
 274                (- a)))
 275            '(let* ((a (and t 1))
 276                    (nil (and a nil))
 277                    (b (and nil 2)))
 278               (if b
 279                   (- a))))))
 280
 281 (ert-deftest subr-x-test-when-let*-malformed-binding ()
 282   "Test malformed bindings trigger errors."
 283   (should-error (macroexpand
 284                  '(when-let* (_ (a 1 1) (b 2) (c 3) d)
 285                     (- a)))
 286                 :type 'error)
 287   (should-error (macroexpand
 288                  '(when-let* (_ (a 1) (b 2 2) (c 3) d)
 289                     (- a)))
 290                 :type 'error)
 291   (should-error (macroexpand
 292                  '(when-let* (_ (a 1) (b 2) (c 3 3) d)
 293                     (- a)))
 294                 :type 'error)
 295   (should-error (macroexpand
 296                  '(when-let* ((a 1 1))
 297                     (- a)))
 298                 :type 'error))
 299
 300 (ert-deftest subr-x-test-when-let*-true ()
 301   "Test `when-let' with truthy bindings."
 302   (should (equal
 303            (when-let* ((a 1))
 304              a)
 305            1))
 306   (should (equal
 307            (when-let* ((a 1) (b 2) (c 3))
 308              (list a b c))
 309            (list 1 2 3))))
 310
 311 (ert-deftest subr-x-test-when-let*-false ()
 312   "Test `when-let' with falsie bindings."
 313   (should (equal
 314            (when-let* ((a nil))
 315              "no")
 316            nil))
 317   (should (equal
 318            (when-let* ((a nil) (b 2) (c 3))
 319              "no")
 320            nil))
 321   (should (equal
 322            (when-let* ((a 1) (b nil) (c 3))
 323              "no")
 324            nil))
 325   (should (equal
 326            (when-let* ((a 1) (b 2) (c nil))
 327              "no")
 328            nil))
 329   (should (equal
 330            (let (z)
 331              (when-let* (z (a 1) (b 2) (c 3))
 332                "no"))
 333            nil))
 334   (should (equal
 335            (let (d)
 336              (when-let* ((a 1) (b 2) (c 3) d)
 337                "no"))
 338            nil)))
 339
 340 (ert-deftest subr-x-test-when-let*-bound-references ()
 341   "Test `when-let' bindings can refer to already bound symbols."
 342   (should (equal
 343            (when-let* ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
 344              (list a b c))
 345            (list 1 2 3))))
 346
 347 (ert-deftest subr-x-test-when-let*-and-laziness-is-preserved ()
 348   "Test `when-let' respects `and' laziness."
 349   (let (a-called b-called c-called)
 350     (should (equal
 351              (progn
 352                (when-let* ((a nil)
 353                            (b (setq b-called t))
 354                            (c (setq c-called t)))
 355                  "yes")
 356                (list a-called b-called c-called))
 357              (list nil nil nil))))
 358   (let (a-called b-called c-called)
 359     (should (equal
 360              (progn
 361                (when-let* ((a (setq a-called t))
 362                            (b nil)
 363                            (c (setq c-called t)))
 364                  "yes")
 365                (list a-called b-called c-called))
 366              (list t nil nil))))
 367   (let (a-called b-called c-called)
 368     (should (equal
 369              (progn
 370                (when-let* ((a (setq a-called t))
 371                            (b (setq b-called t))
 372                            (c nil)
 373                            (d (setq c-called t)))
 374                  "yes")
 375                (list a-called b-called c-called))
 376              (list t t nil)))))
 377
 378 \f
 379 ;; `and-let*' tests
 380
 381 ;; Adapted from the Guile tests
 382 ;; https://git.savannah.gnu.org/cgit/guile.git/tree/test-suite/tests/srfi-2.test
 383
 384 (ert-deftest subr-x-and-let*-test-empty-varlist ()
 385   (should (equal 1 (and-let* () 1)))
 386   (should (equal 2 (and-let* () 1 2)))
 387   (should (equal t (and-let* ()))))
 388
 389 (ert-deftest subr-x-and-let*-test-group-1 ()
 390    (should (equal nil (let ((x nil)) (and-let* (x)))))
 391    (should (equal 1 (let ((x 1)) (and-let* (x)))))
 392    (should (equal nil (and-let* ((x nil)))))
 393    (should (equal 1 (and-let* ((x 1)))))
 394    ;; The error doesn't trigger when compiled: the compiler will give
 395    ;; a warning and then drop the erroneous code.  Therefore, use
 396    ;; `eval' to avoid compilation.
 397    (should-error (eval '(and-let* (nil (x 1))) lexical-binding)
 398                  :type 'setting-constant)
 399    (should (equal nil (and-let* ((nil) (x 1)))))
 400    (should-error (eval '(and-let* (2 (x 1))) lexical-binding)
 401                  :type 'wrong-type-argument)
 402    (should (equal 1 (and-let* ((2) (x 1)))))
 403    (should (equal 2 (and-let* ((x 1) (2)))))
 404    (should (equal nil (let ((x nil)) (and-let* (x) x))))
 405    (should (equal "" (let ((x "")) (and-let* (x) x))))
 406    (should (equal "" (let ((x "")) (and-let* (x)))))
 407    (should (equal 2 (let ((x 1)) (and-let* (x) (+ x 1)))))
 408    (should (equal nil (let ((x nil)) (and-let* (x) (+ x 1)))))
 409    (should (equal 2 (let ((x 1)) (and-let* (((> x 0))) (+ x 1)))))
 410    (should (equal t (let ((x 1)) (and-let* (((> x 0)))))))
 411    (should (equal nil (let ((x 0)) (and-let* (((> x 0))) (+ x 1)))))
 412    (should (equal 3
 413                   (let ((x 1)) (and-let* (((> x 0)) (x (+ x 1))) (+ x 1))))))
 414
 415 (ert-deftest subr-x-and-let*-test-rebind ()
 416    (should
 417     (equal 4
 418            (let ((x 1))
 419              (and-let* (((> x 0)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))))
 420
 421 (ert-deftest subr-x-and-let*-test-group-2 ()
 422    (should
 423     (equal 2 (let ((x 1)) (and-let* (x ((> x 0))) (+ x 1)))))
 424    (should
 425     (equal 2 (let ((x 1)) (and-let* (((progn x)) ((> x 0))) (+ x 1)))))
 426    (should (equal nil (let ((x 0)) (and-let* (x ((> x 0))) (+ x 1)))))
 427    (should (equal nil (let ((x nil)) (and-let* (x ((> x 0))) (+ x 1)))))
 428    (should
 429     (equal nil (let ((x nil)) (and-let* (((progn x)) ((> x 0))) (+ x 1))))))
 430
 431 (ert-deftest subr-x-and-let*-test-group-3 ()
 432    (should
 433     (equal nil (let ((x 1)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
 434    (should
 435     (equal nil (let ((x 0)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
 436    (should
 437     (equal nil
 438            (let ((x nil)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
 439    (should
 440     (equal (/ 3.0 2)
 441            (let ((x 3.0)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y))))))
 442
 443
 444 \f
 445 ;; Thread first tests
 446
 447 (ert-deftest subr-x-test-thread-first-no-forms ()
 448   "Test `thread-first' with no forms expands to the first form."
 449   (should (equal (macroexpand '(thread-first 5)) 5))
 450   (should (equal (macroexpand '(thread-first (+ 1 2))) '(+ 1 2))))
 451
 452 (ert-deftest subr-x-test-thread-first-function-names-are-threaded ()
 453   "Test `thread-first' wraps single function names."
 454   (should (equal (macroexpand
 455                   '(thread-first 5
 456                      -))
 457                  '(- 5)))
 458   (should (equal (macroexpand
 459                   '(thread-first (+ 1 2)
 460                      -))
 461                  '(- (+ 1 2)))))
 462
 463 (ert-deftest subr-x-test-thread-first-expansion ()
 464   "Test `thread-first' expands correctly."
 465   (should (equal
 466            (macroexpand '(thread-first
 467                              5
 468                            (+ 20)
 469                            (/ 25)
 470                            -
 471                            (+ 40)))
 472            '(+ (- (/ (+ 5 20) 25)) 40))))
 473
 474 (ert-deftest subr-x-test-thread-first-examples ()
 475   "Test several `thread-first' examples."
 476   (should (equal (thread-first (+ 40 2)) 42))
 477   (should (equal (thread-first
 478                      5
 479                    (+ 20)
 480                    (/ 25)
 481                    -
 482                    (+ 40)) 39))
 483   (should (equal (thread-first
 484                      "this-is-a-string"
 485                    (split-string "-")
 486                    (nbutlast 2)
 487                    (append (list "good")))
 488                  (list "this" "is" "good"))))
 489 \f
 490 ;; Thread last tests
 491
 492 (ert-deftest subr-x-test-thread-last-no-forms ()
 493   "Test `thread-last' with no forms expands to the first form."
 494   (should (equal (macroexpand '(thread-last 5)) 5))
 495   (should (equal (macroexpand '(thread-last (+ 1 2))) '(+ 1 2))))
 496
 497 (ert-deftest subr-x-test-thread-last-function-names-are-threaded ()
 498   "Test `thread-last' wraps single function names."
 499   (should (equal (macroexpand
 500                   '(thread-last 5
 501                      -))
 502                  '(- 5)))
 503   (should (equal (macroexpand
 504                   '(thread-last (+ 1 2)
 505                      -))
 506                  '(- (+ 1 2)))))
 507
 508 (ert-deftest subr-x-test-thread-last-expansion ()
 509   "Test `thread-last' expands correctly."
 510   (should (equal
 511            (macroexpand '(thread-last
 512                              5
 513                            (+ 20)
 514                            (/ 25)
 515                            -
 516                            (+ 40)))
 517            '(+ 40 (- (/ 25 (+ 20 5)))))))
 518
 519 (ert-deftest subr-x-test-thread-last-examples ()
 520   "Test several `thread-last' examples."
 521   (should (equal (thread-last (+ 40 2)) 42))
 522   (should (equal (thread-last
 523                      5
 524                    (+ 20)
 525                    (/ 25)
 526                    -
 527                    (+ 40)) 39))
 528   (should (equal (thread-last
 529                      (list 1 -2 3 -4 5)
 530                    (mapcar #'abs)
 531                    (cl-reduce #'+)
 532                    (format "abs sum is: %s"))
 533                  "abs sum is: 15")))
 534
 535
 536 (provide 'subr-x-tests)
 537 ;;; subr-x-tests.el ends here