├── .gitignore ├── README.md ├── arrows.lisp ├── cl-arrows.asd ├── packages.lisp └── test.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CL-Arrows 2 | 3 | Implements the `->` and `->>` threading macros in Clojure, as well as `-<>` and `-<>>` 4 | from the [swiss-arrows](https://github.com/rplevy/swiss-arrows) library. 5 | 6 | This is an ASDF system providing the package `cl-arrows`. 7 | 8 | ## Documentation 9 | 10 | [macro] 11 | `->` initial-form _&rest_ forms => results 12 | 13 | Inserts INITIAL-FORM as first argument into the first of FORMS, the result into 14 | the next, etc., before evaluation. FORMS are treated as list designators. 15 | 16 | 17 | [macro] 18 | `->>` initial-form _&rest_ forms => results 19 | 20 | Like `->`, but the forms are inserted as last argument instead of first. 21 | 22 | [macro] 23 | `-<>` initial-form _&rest_ forms => results 24 | 25 | Like `->`, but if a form in FORMS has one or more symbols named `<>` as 26 | top-level element, each such symbol is substituted by the primary result of the 27 | form accumulated so far, instead of it being inserted as first argument. Also 28 | known as diamond wand. 29 | 30 | [macro] 31 | `-<>>` initial-form _&rest_ forms => results 32 | 33 | Like `-<>`, but if a form in FORMS has no symbols named `<>` as top-level element, 34 | insertion is done like in `->>`. Also known as diamond spear. 35 | 36 | ## Examples 37 | 38 | (-> 3 39 | /) ; insert into designated list (/) 40 | => 1/3 41 | 42 | (-> 3 43 | (expt 2)) ; insert as first argument 44 | => 9 45 | 46 | (->> 3 47 | (expt 2)) ; insert as last argument 48 | => 8 49 | 50 | (-<>> (list 1 2 3) 51 | (remove-if #'oddp <> :count 1 :from-end t) ; substitute <> 52 | (reduce #'+) ; insert last 53 | /) ; list designator 54 | => 1/3 55 | 56 | (let ((x 3)) 57 | (-<> (incf x) ; (let ((r (incf x))) 58 | (+ <> <>))) ; (+ r r)) 59 | => 8 60 | 61 | ## Todo 62 | 63 | Future versions _might_ include further ideas from rplevy's 64 | [swiss-arrows](https://github.com/rplevy/swiss-arrows). 65 | -------------------------------------------------------------------------------- /arrows.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-arrows) 2 | 3 | (defun simple-inserter (insert-fun) 4 | (lambda (acc next) 5 | (if (listp next) 6 | (funcall insert-fun acc next) 7 | (list next acc)))) 8 | 9 | (defmacro -> (initial-form &rest forms) 10 | "Inserts INITIAL-FORM as first argument into the first of FORMS, the result 11 | into the next, etc., before evaluation. FORMS are treated as list designators." 12 | (reduce (simple-inserter #'insert-first) 13 | forms 14 | :initial-value initial-form)) 15 | 16 | (defmacro ->> (initial-form &rest forms) 17 | "Like ->, but the forms are inserted as last argument instead of first." 18 | (reduce (simple-inserter #'insert-last) 19 | forms 20 | :initial-value initial-form)) 21 | 22 | (defun diamond-inserter (insert-fun) 23 | (simple-inserter (lambda (acc next) 24 | (case (count-if #'<>p next) 25 | (0 (funcall insert-fun acc next)) 26 | (1 (substitute-if acc #'<>p next)) 27 | (t (let ((r (gensym "R"))) 28 | `(let ((,r ,acc)) 29 | ,(substitute-if r #'<>p next)))))))) 30 | 31 | (defmacro -<> (initial-form &rest forms) 32 | "Like ->, but if a form in FORMS has one or more symbols named <> as top-level 33 | element, each such symbol is substituted by the primary result of the form 34 | accumulated so far, instead of it being inserted as first argument. Also known 35 | as diamond wand." 36 | (reduce (diamond-inserter #'insert-first) 37 | forms 38 | :initial-value initial-form)) 39 | 40 | (defmacro -<>> (initial-form &rest forms) 41 | "Like -<>, but if a form has no symbol named <>, the insertion is done at the 42 | end like in ->>. Also known as diamond spear." 43 | (reduce (diamond-inserter #'insert-last) 44 | forms 45 | :initial-value initial-form)) 46 | 47 | (defun <>p (form) 48 | "Predicate identifying the placeholders for the -<> and -<>> macros." 49 | (and (symbolp form) 50 | (string= form "<>"))) 51 | 52 | (defun insert-first (arg surround) 53 | "Inserts ARG into the list form SURROUND as its first argument, after the 54 | operator." 55 | (list* (car surround) 56 | arg 57 | (cdr surround))) 58 | 59 | (defun insert-last (arg surround) 60 | "Inserts ARG into the list form SURROUND as its last argument." 61 | (append surround (list arg))) 62 | -------------------------------------------------------------------------------- /cl-arrows.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:cl-arrows 2 | :name "cl-arrows" 3 | :version "0.0.1" 4 | :author "Sage Imel" 5 | :description "Implements the -> and ->> from clojure, and -<> and -<>> from swiss-arrows." 6 | :serial t 7 | :components ((:file "packages") 8 | (:file "arrows")) 9 | :in-order-to ((asdf:test-op (asdf:test-op #:cl-arrows-test)))) 10 | 11 | (asdf:defsystem #:cl-arrows-test 12 | :depends-on (#:cl-arrows #:hu.dwim.stefil) 13 | :serial t 14 | :components ((:file "test")) 15 | :perform (asdf:test-op (c v) (uiop:symbol-call '#:cl-arrows-test 16 | '#:test-cl-arrows))) 17 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-arrows 2 | (:use #:common-lisp) 3 | (:export 4 | ;; thrushing macros 5 | #:-> 6 | #:->> 7 | ;; diamond wand/spear 8 | #:-<> 9 | #:-<>>)) 10 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (defpackage #:cl-arrows-test 4 | (:use #:cl #:cl-arrows #:hu.dwim.stefil)) 5 | 6 | (in-package #:cl-arrows-test) 7 | 8 | (defsuite* test-cl-arrows) 9 | 10 | (deftest test--> () 11 | (is (= (-> 3 /) 1/3)) 12 | (is (= (-> 3 (/)) 1/3)) 13 | (is (= (-> 3 (/ 2)) 3/2)) 14 | (is (= (-> 3 (/ 2) /) 2/3))) 15 | 16 | (deftest test-->> () 17 | (is (= (->> 3 /) 1/3)) 18 | (is (= (->> 3 (/)) 1/3)) 19 | (is (= (->> 3 (/ 2)) 2/3)) 20 | (is (= (->> 3 (/ 2) /) 3/2))) 21 | 22 | (deftest test--<> () 23 | (is (= (-<> 3 /) 1/3)) 24 | (is (= (-<> 3 (/)) 1/3)) 25 | (is (= (-<> 3 (/ 2)) 3/2)) 26 | (is (= (-<> 3 (/ 2) /) 2/3)) 27 | (is (= (let ((x 3)) 28 | (-<> (incf x) 29 | (+ <> <>))) 30 | 8))) 31 | 32 | (deftest test--<>> () 33 | (is (= (-<>> 3 /) 1/3)) 34 | (is (= (-<>> 3 (/)) 1/3)) 35 | (is (= (-<>> 3 (/ 2)) 2/3)) 36 | (is (= (-<>> 3 (/ 2) /) 3/2)) 37 | (is (= (-<>> (list 1 2 3) 38 | (remove-if #'oddp <> :count 1 :from-end t) 39 | (reduce #'+) 40 | /) 41 | 1/3))) 42 | --------------------------------------------------------------------------------