;;; Code:
+(require 'pcase)
+
+
+(defmacro internal--thread-argument (first? &rest forms)
+ "Internal implementation for `thread-first' and `thread-last'.
+When Argument FIRST? is non-nil argument is threaded first, else
+last. FORMS are the expressions to be threaded."
+ (pcase forms
+ (`(,x (,f . ,args) . ,rest)
+ `(internal--thread-argument
+ ,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest))
+ (`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest))
+ (_ (car forms))))
+
+(defmacro thread-first (&rest forms)
+ "Thread FORMS elements as the first argument of their succesor.
+Example:
+ (thread-first
+ 5
+ (+ 20)
+ (/ 25)
+ -
+ (+ 40))
+Is equivalent to:
+ (+ (- (/ (+ 5 20) 25)) 40)
+Note how the single `-' got converted into a list before
+threading."
+ (declare (indent 1)
+ (debug (form &rest [&or symbolp (sexp &rest form)])))
+ `(internal--thread-argument t ,@forms))
+
+(defmacro thread-last (&rest forms)
+ "Thread FORMS elements as the last argument of their succesor.
+Example:
+ (thread-last
+ 5
+ (+ 20)
+ (/ 25)
+ -
+ (+ 40))
+Is equivalent to:
+ (+ 40 (- (/ 25 (+ 20 5))))
+Note how the single `-' got converted into a list before
+threading."
+ (declare (indent 1) (debug thread-first))
+ `(internal--thread-argument nil ,@forms))
+
+(defsubst internal--listify (elt)
+ "Wrap ELT in a list if it is not one."
+ (if (not (listp elt))
+ (list elt)
+ elt))
+
+(defsubst internal--check-binding (binding)
+ "Check BINDING is properly formed."
+ (when (> (length binding) 2)
+ (signal
+ 'error
+ (cons "`let' bindings can have only one value-form" binding)))
+ binding)
+
+(defsubst internal--build-binding-value-form (binding prev-var)
+ "Build the conditional value form for BINDING using PREV-VAR."
+ `(,(car binding) (and ,prev-var ,(cadr binding))))
+
+(defun internal--build-binding (binding prev-var)
+ "Check and build a single BINDING with PREV-VAR."
+ (thread-first
+ binding
+ internal--listify
+ internal--check-binding
+ (internal--build-binding-value-form prev-var)))
+
+(defun internal--build-bindings (bindings)
+ "Check and build conditional value forms for BINDINGS."
+ (let ((prev-var t))
+ (mapcar (lambda (binding)
+ (let ((binding (internal--build-binding binding prev-var)))
+ (setq prev-var (car binding))
+ binding))
+ bindings)))
+
+(defmacro if-let (bindings then &rest else)
+ "Process BINDINGS and if all values are non-nil eval THEN, else ELSE.
+Argument BINDINGS is a list of tuples whose car is a symbol to be
+bound and (optionally) used in THEN, and its cadr is a sexp to be
+evaled to set symbol's value. In the special case you only want
+to bind a single value, BINDINGS can just be a plain tuple."
+ (declare (indent 2) (debug ((&rest (symbolp form)) form body)))
+ (when (and (<= (length bindings) 2)
+ (not (listp (car bindings))))
+ ;; Adjust the single binding case
+ (setq bindings (list bindings)))
+ `(let* ,(internal--build-bindings bindings)
+ (if ,(car (internal--listify (car (last bindings))))
+ ,then
+ ,@else)))
+
+(defmacro when-let (bindings &rest body)
+ "Process BINDINGS and if all values are non-nil eval BODY.
+Argument BINDINGS is a list of tuples whose car is a symbol to be
+bound and (optionally) used in BODY, and its cadr is a sexp to be
+evaled to set symbol's value. In the special case you only want
+to bind a single value, BINDINGS can just be a plain tuple."
+ (declare (indent 1) (debug if-let))
+ (list 'if-let bindings (macroexp-progn body)))
+
(defsubst hash-table-keys (hash-table)
"Return a list of keys in HASH-TABLE."
(let ((keys '()))
--- /dev/null
+;;; subr-x-tests.el --- Testing the extended lisp routines
+
+;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
+
+;; Author: Fabián E. Gallina <fgallina@gnu.org>
+;; Keywords:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'ert)
+(require 'subr-x)
+
+\f
+;; if-let tests
+
+(ert-deftest subr-x-test-if-let-single-binding-expansion ()
+ "Test single bindings are expanded properly."
+ (should (equal
+ (macroexpand
+ '(if-let (a 1)
+ (- a)
+ "no"))
+ '(let* ((a (and t 1)))
+ (if a
+ (- a)
+ "no"))))
+ (should (equal
+ (macroexpand
+ '(if-let (a)
+ (- a)
+ "no"))
+ '(let* ((a (and t nil)))
+ (if a
+ (- a)
+ "no")))))
+
+(ert-deftest subr-x-test-if-let-single-symbol-expansion ()
+ "Test single symbol bindings are expanded properly."
+ (should (equal
+ (macroexpand
+ '(if-let (a)
+ (- a)
+ "no"))
+ '(let* ((a (and t nil)))
+ (if a
+ (- a)
+ "no"))))
+ (should (equal
+ (macroexpand
+ '(if-let (a b c)
+ (- a)
+ "no"))
+ '(let* ((a (and t nil))
+ (b (and a nil))
+ (c (and b nil)))
+ (if c
+ (- a)
+ "no"))))
+ (should (equal
+ (macroexpand
+ '(if-let (a (b 2) c)
+ (- a)
+ "no"))
+ '(let* ((a (and t nil))
+ (b (and a 2))
+ (c (and b nil)))
+ (if c
+ (- a)
+ "no")))))
+
+(ert-deftest subr-x-test-if-let-nil-related-expansion ()
+ "Test nil is processed properly."
+ (should (equal
+ (macroexpand
+ '(if-let (nil)
+ (- a)
+ "no"))
+ '(let* ((nil (and t nil)))
+ (if nil
+ (- a)
+ "no"))))
+ (should (equal
+ (macroexpand
+ '(if-let ((nil))
+ (- a)
+ "no"))
+ '(let* ((nil (and t nil)))
+ (if nil
+ (- a)
+ "no"))))
+ (should (equal
+ (macroexpand
+ '(if-let ((a 1) (nil) (b 2))
+ (- a)
+ "no"))
+ '(let* ((a (and t 1))
+ (nil (and a nil))
+ (b (and nil 2)))
+ (if b
+ (- a)
+ "no"))))
+ (should (equal
+ (macroexpand
+ '(if-let ((a 1) nil (b 2))
+ (- a)
+ "no"))
+ '(let* ((a (and t 1))
+ (nil (and a nil))
+ (b (and nil 2)))
+ (if b
+ (- a)
+ "no")))))
+
+(ert-deftest subr-x-test-if-let-malformed-binding ()
+ "Test malformed bindings trigger errors."
+ (should-error (macroexpand
+ '(if-let (_ (a 1 1) (b 2) (c 3) d)
+ (- a)
+ "no"))
+ :type 'error)
+ (should-error (macroexpand
+ '(if-let (_ (a 1) (b 2 2) (c 3) d)
+ (- a)
+ "no"))
+ :type 'error)
+ (should-error (macroexpand
+ '(if-let (_ (a 1) (b 2) (c 3 3) d)
+ (- a)
+ "no"))
+ :type 'error)
+ (should-error (macroexpand
+ '(if-let ((a 1 1))
+ (- a)
+ "no"))
+ :type 'error))
+
+(ert-deftest subr-x-test-if-let-true ()
+ "Test `if-let' with truthy bindings."
+ (should (equal
+ (if-let (a 1)
+ a
+ "no")
+ 1))
+ (should (equal
+ (if-let ((a 1) (b 2) (c 3))
+ (list a b c)
+ "no")
+ (list 1 2 3))))
+
+(ert-deftest subr-x-test-if-let-false ()
+ "Test `if-let' with falsey bindings."
+ (should (equal
+ (if-let (a nil)
+ (list a b c)
+ "no")
+ "no"))
+ (should (equal
+ (if-let ((a nil) (b 2) (c 3))
+ (list a b c)
+ "no")
+ "no"))
+ (should (equal
+ (if-let ((a 1) (b nil) (c 3))
+ (list a b c)
+ "no")
+ "no"))
+ (should (equal
+ (if-let ((a 1) (b 2) (c nil))
+ (list a b c)
+ "no")
+ "no"))
+ (should (equal
+ (if-let (z (a 1) (b 2) (c 3))
+ (list a b c)
+ "no")
+ "no"))
+ (should (equal
+ (if-let ((a 1) (b 2) (c 3) d)
+ (list a b c)
+ "no")
+ "no")))
+
+(ert-deftest subr-x-test-if-let-bound-references ()
+ "Test `if-let' bindings can refer to already bound symbols."
+ (should (equal
+ (if-let ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
+ (list a b c)
+ "no")
+ (list 1 2 3))))
+
+(ert-deftest subr-x-test-if-let-and-lazyness-is-preserved ()
+ "Test `if-let' respects `and' lazyness."
+ (let (a-called b-called c-called)
+ (should (equal
+ (if-let ((a nil)
+ (b (setq b-called t))
+ (c (setq c-called t)))
+ "yes"
+ (list a-called b-called c-called))
+ (list nil nil nil))))
+ (let (a-called b-called c-called)
+ (should (equal
+ (if-let ((a (setq a-called t))
+ (b nil)
+ (c (setq c-called t)))
+ "yes"
+ (list a-called b-called c-called))
+ (list t nil nil))))
+ (let (a-called b-called c-called)
+ (should (equal
+ (if-let ((a (setq a-called t))
+ (b (setq b-called t))
+ (c nil)
+ (d (setq c-called t)))
+ "yes"
+ (list a-called b-called c-called))
+ (list t t nil)))))
+
+\f
+;; when-let tests
+
+(ert-deftest subr-x-test-when-let-body-expansion ()
+ "Test body allows for multiple sexps wrapping with progn."
+ (should (equal
+ (macroexpand
+ '(when-let (a 1)
+ (message "opposite")
+ (- a)))
+ '(let* ((a (and t 1)))
+ (if a
+ (progn
+ (message "opposite")
+ (- a)))))))
+
+(ert-deftest subr-x-test-when-let-single-binding-expansion ()
+ "Test single bindings are expanded properly."
+ (should (equal
+ (macroexpand
+ '(when-let (a 1)
+ (- a)))
+ '(let* ((a (and t 1)))
+ (if a
+ (- a)))))
+ (should (equal
+ (macroexpand
+ '(when-let (a)
+ (- a)))
+ '(let* ((a (and t nil)))
+ (if a
+ (- a))))))
+
+(ert-deftest subr-x-test-when-let-single-symbol-expansion ()
+ "Test single symbol bindings are expanded properly."
+ (should (equal
+ (macroexpand
+ '(when-let (a)
+ (- a)))
+ '(let* ((a (and t nil)))
+ (if a
+ (- a)))))
+ (should (equal
+ (macroexpand
+ '(when-let (a b c)
+ (- a)))
+ '(let* ((a (and t nil))
+ (b (and a nil))
+ (c (and b nil)))
+ (if c
+ (- a)))))
+ (should (equal
+ (macroexpand
+ '(when-let (a (b 2) c)
+ (- a)))
+ '(let* ((a (and t nil))
+ (b (and a 2))
+ (c (and b nil)))
+ (if c
+ (- a))))))
+
+(ert-deftest subr-x-test-when-let-nil-related-expansion ()
+ "Test nil is processed properly."
+ (should (equal
+ (macroexpand
+ '(when-let (nil)
+ (- a)))
+ '(let* ((nil (and t nil)))
+ (if nil
+ (- a)))))
+ (should (equal
+ (macroexpand
+ '(when-let ((nil))
+ (- a)))
+ '(let* ((nil (and t nil)))
+ (if nil
+ (- a)))))
+ (should (equal
+ (macroexpand
+ '(when-let ((a 1) (nil) (b 2))
+ (- a)))
+ '(let* ((a (and t 1))
+ (nil (and a nil))
+ (b (and nil 2)))
+ (if b
+ (- a)))))
+ (should (equal
+ (macroexpand
+ '(when-let ((a 1) nil (b 2))
+ (- a)))
+ '(let* ((a (and t 1))
+ (nil (and a nil))
+ (b (and nil 2)))
+ (if b
+ (- a))))))
+
+(ert-deftest subr-x-test-when-let-malformed-binding ()
+ "Test malformed bindings trigger errors."
+ (should-error (macroexpand
+ '(when-let (_ (a 1 1) (b 2) (c 3) d)
+ (- a)))
+ :type 'error)
+ (should-error (macroexpand
+ '(when-let (_ (a 1) (b 2 2) (c 3) d)
+ (- a)))
+ :type 'error)
+ (should-error (macroexpand
+ '(when-let (_ (a 1) (b 2) (c 3 3) d)
+ (- a)))
+ :type 'error)
+ (should-error (macroexpand
+ '(when-let ((a 1 1))
+ (- a)))
+ :type 'error))
+
+(ert-deftest subr-x-test-when-let-true ()
+ "Test `when-let' with truthy bindings."
+ (should (equal
+ (when-let (a 1)
+ a)
+ 1))
+ (should (equal
+ (when-let ((a 1) (b 2) (c 3))
+ (list a b c))
+ (list 1 2 3))))
+
+(ert-deftest subr-x-test-when-let-false ()
+ "Test `when-let' with falsey bindings."
+ (should (equal
+ (when-let (a nil)
+ (list a b c)
+ "no")
+ nil))
+ (should (equal
+ (when-let ((a nil) (b 2) (c 3))
+ (list a b c)
+ "no")
+ nil))
+ (should (equal
+ (when-let ((a 1) (b nil) (c 3))
+ (list a b c)
+ "no")
+ nil))
+ (should (equal
+ (when-let ((a 1) (b 2) (c nil))
+ (list a b c)
+ "no")
+ nil))
+ (should (equal
+ (when-let (z (a 1) (b 2) (c 3))
+ (list a b c)
+ "no")
+ nil))
+ (should (equal
+ (when-let ((a 1) (b 2) (c 3) d)
+ (list a b c)
+ "no")
+ nil)))
+
+(ert-deftest subr-x-test-when-let-bound-references ()
+ "Test `when-let' bindings can refer to already bound symbols."
+ (should (equal
+ (when-let ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
+ (list a b c))
+ (list 1 2 3))))
+
+(ert-deftest subr-x-test-when-let-and-lazyness-is-preserved ()
+ "Test `when-let' respects `and' lazyness."
+ (let (a-called b-called c-called)
+ (should (equal
+ (progn
+ (when-let ((a nil)
+ (b (setq b-called t))
+ (c (setq c-called t)))
+ "yes")
+ (list a-called b-called c-called))
+ (list nil nil nil))))
+ (let (a-called b-called c-called)
+ (should (equal
+ (progn
+ (when-let ((a (setq a-called t))
+ (b nil)
+ (c (setq c-called t)))
+ "yes")
+ (list a-called b-called c-called))
+ (list t nil nil))))
+ (let (a-called b-called c-called)
+ (should (equal
+ (progn
+ (when-let ((a (setq a-called t))
+ (b (setq b-called t))
+ (c nil)
+ (d (setq c-called t)))
+ "yes")
+ (list a-called b-called c-called))
+ (list t t nil)))))
+
+\f
+;; Thread first tests
+
+(ert-deftest subr-x-test-thread-first-no-forms ()
+ "Test `thread-first' with no forms expands to the first form."
+ (should (equal (macroexpand '(thread-first 5)) 5))
+ (should (equal (macroexpand '(thread-first (+ 1 2))) '(+ 1 2))))
+
+(ert-deftest subr-x-test-thread-first-function-names-are-threaded ()
+ "Test `thread-first' wraps single function names."
+ (should (equal (macroexpand
+ '(thread-first 5
+ -))
+ '(- 5)))
+ (should (equal (macroexpand
+ '(thread-first (+ 1 2)
+ -))
+ '(- (+ 1 2)))))
+
+(ert-deftest subr-x-test-thread-first-expansion ()
+ "Test `thread-first' expands correctly."
+ (should (equal
+ (macroexpand '(thread-first
+ 5
+ (+ 20)
+ (/ 25)
+ -
+ (+ 40)))
+ '(+ (- (/ (+ 5 20) 25)) 40))))
+
+(ert-deftest subr-x-test-thread-first-examples ()
+ "Test several `thread-first' examples."
+ (should (equal (thread-first (+ 40 2)) 42))
+ (should (equal (thread-first
+ 5
+ (+ 20)
+ (/ 25)
+ -
+ (+ 40)) 39))
+ (should (equal (thread-first
+ "this-is-a-string"
+ (split-string "-")
+ (nbutlast 2)
+ (append (list "good")))
+ (list "this" "is" "good"))))
+\f
+;; Thread last tests
+
+(ert-deftest subr-x-test-thread-last-no-forms ()
+ "Test `thread-last' with no forms expands to the first form."
+ (should (equal (macroexpand '(thread-last 5)) 5))
+ (should (equal (macroexpand '(thread-last (+ 1 2))) '(+ 1 2))))
+
+(ert-deftest subr-x-test-thread-last-function-names-are-threaded ()
+ "Test `thread-last' wraps single function names."
+ (should (equal (macroexpand
+ '(thread-last 5
+ -))
+ '(- 5)))
+ (should (equal (macroexpand
+ '(thread-last (+ 1 2)
+ -))
+ '(- (+ 1 2)))))
+
+(ert-deftest subr-x-test-thread-last-expansion ()
+ "Test `thread-last' expands correctly."
+ (should (equal
+ (macroexpand '(thread-last
+ 5
+ (+ 20)
+ (/ 25)
+ -
+ (+ 40)))
+ '(+ 40 (- (/ 25 (+ 20 5)))))))
+
+(ert-deftest subr-x-test-thread-last-examples ()
+ "Test several `thread-last' examples."
+ (should (equal (thread-last (+ 40 2)) 42))
+ (should (equal (thread-last
+ 5
+ (+ 20)
+ (/ 25)
+ -
+ (+ 40)) 39))
+ (should (equal (thread-last
+ (list 1 -2 3 -4 5)
+ (mapcar #'abs)
+ (cl-reduce #'+)
+ (format "abs sum is: %s"))
+ "abs sum is: 15")))
+
+
+(provide 'subr-x-tests)
+;;; subr-x-tests.el ends here