From 2e3994270c9dee76f3c8141d8672c37661c9494d Mon Sep 17 00:00:00 2001 From: Andrea Richiardi Date: Fri, 29 Nov 2019 19:04:04 -0800 Subject: [PATCH] Introduce line-up-first and line-up-last macros This patch introduces the line-up-first and line-up-last macros in control-flow. The macros have been popularized by Clojure and afterwards adopted in Emacs Lisp (see thread-first and thread-last in subr-x.el). This implementation is a port of the latter, where we use a common line-up-iter(ative) tail recursive function for computing the results. The choice of the full name was made in the spirit of the library, conservatively avoiding new syntax like -> or ->>. --- alexandria-2/control-flow.lisp | 46 +++++++++++++++ alexandria-2/package.lisp | 6 +- alexandria-2/tests.lisp | 105 +++++++++++++++++++++++++++++++++ 3 files changed, 155 insertions(+), 2 deletions(-) create mode 100644 alexandria-2/control-flow.lisp diff --git a/alexandria-2/control-flow.lisp b/alexandria-2/control-flow.lisp new file mode 100644 index 0000000..a78bd55 --- /dev/null +++ b/alexandria-2/control-flow.lisp @@ -0,0 +1,46 @@ +(in-package :alexandria-2) + +(defun line-up-iter (thread-first-p acc forms) + "Iterative implementation for `thread-iter'. + +The THREAD-FIRST-P decides where to thread the FORMS, accumulating in ACC." + (if forms + (thread-iter thread-first-p + (let ((form (car forms))) + (if (listp form) + (if thread-first-p + (apply #'list (car form) acc (cdr form)) + (append form (cons acc nil))) + (list form acc))) + (cdr forms)) + acc)) + +(defmacro line-up-first (&rest forms) + "Lines up FORMS elements as the first argument of their successor. +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." + (line-up-iter t (car forms) (cdr forms))) + +(defmacro line-up-last (&rest forms) + "Lines up FORMS elements as the last argument of their successor. +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." + (line-up-iter nil (car forms) (cdr forms))) diff --git a/alexandria-2/package.lisp b/alexandria-2/package.lisp index 21ceaf6..5da434e 100644 --- a/alexandria-2/package.lisp +++ b/alexandria-2/package.lisp @@ -3,7 +3,9 @@ (:use :cl :alexandria.1.0.0) #+sb-package-locks (:lock t) - (:export - #:delete-from-plist* + (:export + #:delete-from-plist* + #:line-up-first + #:line-up-last . #. (let (res) (do-external-symbols (sym :alexandria.1.0.0) (push sym res)) res) )) diff --git a/alexandria-2/tests.lisp b/alexandria-2/tests.lisp index 55a3b86..4848382 100644 --- a/alexandria-2/tests.lisp +++ b/alexandria-2/tests.lisp @@ -19,3 +19,108 @@ ((b 2 d 4 d 5) ((c . 3) (a . 1)))) + +;; Control Flow tests + +(deftest line-up-first.no-form + (values + (equal (macroexpand '(line-up-first 5)) + 5) + (equal (macroexpand '(line-up-first (+ 1 2))) + '(+ 1 2))) + t + t) + +(deftest line-up-first.function-names-are-threaded + (values + (equal (macroexpand '(line-up-first 5 -)) + '(- 5)) + (equal (macroexpand '(line-up-first (+ 1 2) -)) + '(- (+ 1 2)))) + t + t) + +(deftest line-up-first.list-promotion + (macroexpand '(line-up-first + 5 + (+ 20) + (/ 25) + - + (+ 40))) + (+ (- (/ (+ 5 20) 25)) 40) + t) + +(deftest line-up-first.multiple-args + (macroexpand '(line-up-first + "this-is-a-string" + (subseq 0 4))) + (subseq "this-is-a-string" 0 4) + t) + +(deftest line-up-first.several-examples + (values + (equal (line-up-first (+ 40 2)) 42) + (equal (line-up-first + 5 + (+ 20) + (/ 25) + - + (+ 40)) 39) + (equal (line-up-first + "this-is-a-string" + (subseq 4 5) + (string-trim "--------good")) + "good")) + t + t + t) + +;; Thread last tests + +(deftest line-up-last.no-forms + (values + (equal (macroexpand '(line-up-last 5)) 5) + (equal (macroexpand '(line-up-last (+ 1 2))) '(+ 1 2))) + t + t) + +(deftest line-up-last.function-names-are-threaded + (values (equal (macroexpand + '(line-up-last 5 + -)) + '(- 5)) + (equal (macroexpand + '(line-up-last (+ 1 2) + -)) + '(- (+ 1 2)))) + t + t) + +(deftest line-up-last.lisp-promotion + (macroexpand '(line-up-last + 5 + (+ 20) + (/ 25) + - + (+ 40))) + (+ 40 (- (/ 25 (+ 20 5)))) + t) + +(deftest line-up-last.several-examples + (values (equal (line-up-last (+ 40 2)) 42) + (equal (line-up-last + 5 + (+ 20) + (/ 25) + - + (+ 40)) + 39) + (equal (line-up-last + (list 1 -2 3 -4 5) + (mapcar #'abs) + (reduce #'+) + (format nil "abs sum is: ~D")) + "abs sum is: 15")) + t + t + t) -- GitLab