├── .circleci └── config.yml ├── .gitignore ├── LICENSE ├── README.md ├── easy-macros.asd ├── macros.lisp ├── run-circleci.lisp └── test-macros.lisp /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: cimg/base:2021.04 6 | steps: 7 | - checkout 8 | - run: 9 | name: Install SBCL 10 | command: sudo apt-get update && sudo apt-get install -y sbcl 11 | - run: 12 | name: Install quicklisp 13 | command: | 14 | curl -O https://beta.quicklisp.org/quicklisp.lisp 15 | sbcl --load quicklisp.lisp --eval '(quicklisp-quickstart:install)' 16 | - run: 17 | name: Run tests 18 | command: sbcl --script run-circleci.lisp 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | build -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # easy-macros: An easy way to write 90% of your macros 3 | 4 | [![tdrhq](https://circleci.com/gh/tdrhq/easy-macros.svg?style=shield)](https://app.circleci.com/pipelines/github/tdrhq/easy-macros?branch=main) 5 | 6 | Easy-macros help you write macros of this form: 7 | 8 | ```lisp 9 | (with- (...args...) 10 | ...body...) 11 | ``` 12 | 13 | Under the hood, this automates the call-with pattern. 14 | 15 | ## Examples 16 | 17 | Let's rewrite some well known examples to show what we mean. 18 | 19 | ### ignore-errors 20 | 21 | First let's see how we might write `ignore-errors` the Old-Fashioned 22 | way: 23 | 24 | ```lisp 25 | (defmacro custom-ignore-errors (&body body) 26 | `(handler-case 27 | (progn ,@body) 28 | (error () nil))) 29 | ``` 30 | 31 | Not too bad, but it's error-prone. You might forget to use a `,`, you 32 | might forget to wrap body in `progn` etc. But worst, if you change the 33 | definition of `custom-ignore-errors`, you will have to recompile all 34 | the functions that use it. 35 | 36 | You can avoid some of these issues by using the CALL-WITH pattern: 37 | 38 | ```lisp 39 | (defmacro custom-ignore-errors (&body body) 40 | `(call-custom-ignore-errors (lambda () ,@body))) 41 | 42 | (defun call-custom-ignore-errors (fn) 43 | (handler-case 44 | (funcall fn) 45 | (error () nil))) 46 | ``` 47 | 48 | Now most of the logic is inside a non-backticked function. But there's 49 | still some backquoting and macro expansion we need to do which is 50 | error-prone, and it's also very verbose for simple macros. 51 | 52 | Use `def-easy-macro` to essentially automate this process: 53 | 54 | ```lisp 55 | (def-easy-macro custom-ignore-errors (&fn fn) 56 | (handler-case 57 | (funcall fn) 58 | (error () nil))) 59 | ``` 60 | 61 | This `custom-ignore-errors` has a slightly different API though: 62 | 63 | ```lisp 64 | (custom-ignore-errors () 65 | ...body...) 66 | ``` 67 | 68 | All easy-macros takes a second list for arguments. This is true even 69 | if it takes no arguments and only a body. 70 | 71 | Notice a few things: 72 | * We don't use backticks anywhere 73 | * Instead of a body, we get a lambda function. This function is provided by the `&fn` argument. 74 | * If you redefine custom-ignore-errors, all callers of the macro will 75 | point to the new code, unlike with regular macros. (With some caveats! See below.) 76 | 77 | We don't need to use `funcall` by the way, the following is equivalent: 78 | 79 | ```lisp 80 | (def-easy-macro custom-ignore-errors (&fn fn) 81 | (handler-case 82 | (fn) 83 | (error () nil))) 84 | ``` 85 | 86 | We're still figuring out which one we like better. This version 87 | obviously is lesser code, but it also breaks the expectation that 88 | arguments in the lambda-list are variables. But anyway, moving on to 89 | next examples. 90 | 91 | 92 | ### with-open-file 93 | 94 | ```lisp 95 | (def-easy-macro with-custom-open-file (&binding stream file &rest args &fn fn) 96 | (let ((stream (apply #'open file args))) 97 | (unwind-protect 98 | (funcall fn stream) 99 | (close stream)))) 100 | ``` 101 | 102 | This can be used almost exactly like with-open-file. 103 | 104 | Notice a few things: 105 | * We don't use backticks anywhere 106 | * This function takes one argument. easy-macro knows this based on the 107 | `&binding` argument, unlike the previous example. 108 | 109 | ### uiop:with-temporary-file 110 | 111 | ```lisp 112 | (def-easy-macro my-with-custom-temporary-file (&key &binding stream &binding pathname prefix suffix &fn) 113 | ;; ... you get the idea 114 | (funcall fn my-stream my-pathname)) 115 | ``` 116 | 117 | I didn't build out the example completely, but I wanted to show you 118 | how you could write more complex arguments in the macro. 119 | 120 | All the arguments named with `&binding` are not part of argument-list, 121 | they will be sequentially bound to the `&fn` body function. The rest 122 | of expressions form the lambda-list for the argument-list. 123 | 124 | ### maplist 125 | 126 | Common Lisp comes with `dolist`, but not a `maplist`. Let's implement 127 | a quick `maplist` macro using `loop`: 128 | 129 | ```lisp 130 | (def-easy-macro maplist (&binding x list &fn fn) 131 | (loop for value in list collect (funcall fn value)) 132 | ``` 133 | 134 | Before `def-easy-macro` this would've been too much work to define for 135 | something simple. With `def-easy-macro` it's just as easy to work with 136 | as any regular function, so you tend to macrofy even tiny abstractions 137 | like this. 138 | 139 | 140 | ## Caveats with redefinitions 141 | 142 | Most redefinitions will automatically be applied to all callers. If 143 | you change the lambda-list (either `&binding` or otherwise), the new 144 | definition may not be compatible. 145 | 146 | ## Installation 147 | 148 | We're waiting on this to be part of the next Quicklisp distribution, 149 | in the meantime you can use quick-patch to install: 150 | 151 | ```lisp 152 | (ql:quickload :quick-patch) 153 | (quick-patch:register "https://github.com/tdrhq/easy-macros.git" "main") 154 | (quick-patch:checkout-all ".quick-patch/") 155 | ``` 156 | 157 | ## TODO 158 | 159 | This library is NOT very polished. 160 | 161 | However, even with its limited polish it's been ridiculously useful in 162 | my work, so I thought I should put it out there and accept feedback 163 | and pull requests. There are few things that I'd personally like to see: 164 | 165 | * Less brittle lambda-list parsing: currently it's really hacky 166 | * A way to implement macros of the form: 167 | ```lisp 168 | (def-stuff my-stuff (...) 169 | ,@body) 170 | ``` 171 | * In a similar vein as above: sometimes in macros you want to pass the 172 | quoted symbol name instead of the evaluated expression. In theory I 173 | can build that... 174 | * But I want to limit what this library does. I want to make it easy 175 | for somebody new to CL to write macros *most* of the time. Just 176 | because I can doesn't mean I should. 177 | 178 | ## Author 179 | 180 | Arnold Noronha 181 | 182 | ## License 183 | 184 | Apache License, Version 2.0 185 | -------------------------------------------------------------------------------- /easy-macros.asd: -------------------------------------------------------------------------------- 1 | ;;;; Copyright 2018-Present Modern Interpreters Inc. 2 | ;;;; 3 | ;;;; This Source Code Form is subject to the terms of the Mozilla Public 4 | ;;;; License, v. 2.0. If a copy of the MPL was not distributed with this 5 | ;;;; file, You can obtain one at https://mozilla.org/MPL/2.0/. 6 | 7 | (defsystem :easy-macros 8 | :description "An easier way to write 90% of your macros" 9 | :author "Arnold Noronha " 10 | :license "Apache License, Version 2.0" 11 | :serial t 12 | :depends-on () 13 | :components ((:file "macros"))) 14 | 15 | (defsystem :easy-macros/tests 16 | :serial t 17 | :depends-on (:easy-macros 18 | :fiveam 19 | :alexandria 20 | :fiveam-matchers) 21 | :components ((:file "test-macros"))) 22 | -------------------------------------------------------------------------------- /macros.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright 2018-Present Modern Interpreters Inc. 2 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 3 | ;; you may not use this file except in compliance with the License. 4 | ;; You may obtain a copy of the License at 5 | ;; 6 | ;; http://www.apache.org/licenses/LICENSE-2.0 7 | ;; 8 | ;; Unless required by applicable law or agreed to in writing, software 9 | ;; distributed under the License is distributed on an "AS IS" BASIS, 10 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | ;; See the License for the specific language governing permissions and 12 | ;; limitations under the License. 13 | 14 | (defpackage :easy-macros 15 | (:use #:cl) 16 | (:export 17 | #:def-easy-macro)) 18 | (in-package :easy-macros) 19 | 20 | (define-condition unsupported-lambda-list (error) 21 | ((reason :initarg :reason))) 22 | 23 | (defun build-funcall (fn-name real-fn-args fn-arg-values body) 24 | `(,fn-name (lambda (,@ (loop for x in (get-bindings real-fn-args fn-arg-values) 25 | if x collect x 26 | else collect (gensym))) ,@body) 27 | ,@ (get-non-bindings real-fn-args fn-arg-values))) 28 | 29 | (defun remove-defaults (x) 30 | "Remove default values from an argument to just get the name" 31 | (etypecase x 32 | (symbol 33 | x) 34 | (list 35 | (car x)))) 36 | 37 | (defun get-bindings (real-fn-args fn-arg-values) 38 | (let ((fn-args (remove-&fn real-fn-args))) 39 | (let ((expr `(destructuring-bind 40 | ,(loop for x in fn-args 41 | if (binding-sym-p x) 42 | collect (name x) 43 | else 44 | collect (remove-defaults x)) 45 | ',fn-arg-values 46 | (list ,@ (let ((seen-&key nil)) 47 | (loop for x in fn-args 48 | if (eql '&key x) 49 | do 50 | (setf seen-&key t) 51 | if (and (binding-sym-p x)) 52 | collect 53 | (name x))))))) 54 | #+nil 55 | (log:info "Going to eval expr: ~s" expr) 56 | (eval expr)))) 57 | 58 | (defun get-non-bindings (real-fn-args fn-arg-values) 59 | "Carefully remove all the fn-arg-values that correspond to bindings" 60 | (let ((fn-args (remove-&fn real-fn-args))) 61 | (labels ((is-binding-key (name) 62 | (loop for x in fn-args 63 | if (and 64 | (binding-sym-p x) 65 | (string= (string (name x)) (string name))) 66 | return t)) 67 | (%get-non-bindings (args value-exprs keysp) 68 | #+nil 69 | (log:info "Looking at ~a ~a" args value-exprs) 70 | (cond 71 | ((null value-exprs) 72 | value-exprs) 73 | ((and (binding-sym-p (car args)) 74 | (not keysp)) 75 | (%get-non-bindings (cdr args) 76 | (cdr value-exprs) 77 | keysp)) 78 | ((and (eql (car args) 'cl:&key) 79 | (not keysp)) 80 | (list* 81 | (%get-non-bindings args 82 | value-exprs 83 | t))) 84 | ((and keysp (is-binding-key (car value-exprs))) 85 | (%get-non-bindings args 86 | (cddr value-exprs) 87 | t)) 88 | (keysp 89 | (assert (not (is-binding-key (car value-exprs)))) 90 | (list* 91 | (car value-exprs) 92 | (cadr value-exprs) 93 | (%get-non-bindings args 94 | (cddr value-exprs) 95 | t))) 96 | (t 97 | (list* 98 | (car value-exprs) 99 | (%get-non-bindings (cdr args) 100 | (cdr value-exprs) 101 | keysp)))))) 102 | (%get-non-bindings fn-args fn-arg-values nil)))) 103 | 104 | (defun is-sym (sym looking-for) 105 | (when (and 106 | (symbolp sym) 107 | (symbolp looking-for)) 108 | (string= (string sym) (string looking-for)))) 109 | 110 | (defclass binding-sym () 111 | ((name :initarg :name 112 | :reader name))) 113 | 114 | (defun binding-sym-p (x) 115 | (typep x 'binding-sym)) 116 | 117 | (defun check-validity (args) 118 | (labels ((%check (args seen-key seen-rest) 119 | (when args 120 | (destructuring-bind (next &rest rest) args 121 | (cond 122 | ((is-sym next '&binding) 123 | (when seen-rest 124 | (error 'unsupported-lambda-list 125 | :reason "&binding not supported after &rest")) 126 | (%check (cdr rest) seen-key seen-rest)) 127 | ((eql next 'cl:&key) 128 | (%check rest t seen-rest)) 129 | ((eql rest 'cl:&rest) 130 | (%check rest seen-key t)) 131 | (t 132 | (%check rest seen-key seen-rest)))))) 133 | ) 134 | (%check args nil nil))) 135 | 136 | (defun remove-&fn (args) 137 | (check-validity args) 138 | (let ((fn nil)) 139 | (let ((result 140 | (loop while args 141 | for next = (car args) 142 | if (is-sym next '&fn) 143 | do 144 | (setf fn (cadr args)) 145 | (setf args (cddr args)) 146 | else if (is-sym next '&binding) 147 | collect 148 | (prog1 149 | (make-instance 'binding-sym :name (cadr args)) 150 | (setf args (cddr args))) 151 | else 152 | collect 153 | (progn 154 | (setf args (cdr args)) 155 | next)))) 156 | (values result (or fn (gensym "fn")))))) 157 | 158 | (defun remove-binding-syms (args) 159 | (loop for x in args 160 | if (not (typep x 'binding-sym)) 161 | collect x into final-arg 162 | else 163 | collect x into binding-syms 164 | finally (return (values final-arg binding-syms)))) 165 | 166 | (defmacro def-easy-macro (name real-fn-args &body body) 167 | (let ((fn-name (intern (format nil "CALL-~a" (string name)) *package*))) 168 | (multiple-value-bind (fn-args body-fn) (remove-&fn real-fn-args) 169 | (multiple-value-bind (body decl doc) 170 | (uiop:parse-body body :documentation t) 171 | `(progn 172 | (defun ,fn-name (,body-fn ,@ (remove-binding-syms fn-args)) 173 | ,@decl 174 | (flet ((,body-fn (&rest args) 175 | (declare (inline)) 176 | (apply ,body-fn args))) 177 | ,@body)) 178 | (defmacro ,name ((&rest fn-arg-values) &body macro-body) 179 | ,doc 180 | (build-funcall ',fn-name ',real-fn-args fn-arg-values macro-body))))))) 181 | -------------------------------------------------------------------------------- /run-circleci.lisp: -------------------------------------------------------------------------------- 1 | (load "~/quicklisp/setup.lisp") 2 | 3 | (push #P "./" asdf:*central-registry*) 4 | 5 | (ql:quickload :quick-patch) 6 | (quick-patch:register "https://github.com/tdrhq/fiveam-matchers.git" 7 | "master") 8 | (quick-patch:checkout-all "build/quick-patch-oss/") 9 | 10 | (ql:quickload :easy-macros/tests) 11 | 12 | (unless (fiveam:run-all-tests) 13 | (uiop:quit 1)) 14 | 15 | (uiop:quit 0) 16 | -------------------------------------------------------------------------------- /test-macros.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright 2018-Present Modern Interpreters Inc. 2 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 3 | ;; you may not use this file except in compliance with the License. 4 | ;; You may obtain a copy of the License at 5 | ;; 6 | ;; http://www.apache.org/licenses/LICENSE-2.0 7 | ;; 8 | ;; Unless required by applicable law or agreed to in writing, software 9 | ;; distributed under the License is distributed on an "AS IS" BASIS, 10 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | ;; See the License for the specific language governing permissions and 12 | ;; limitations under the License. 13 | 14 | (defpackage :easy-macros/test-macros 15 | (:use #:cl 16 | #:easy-macros 17 | #:fiveam) 18 | (:import-from #:easy-macros 19 | #:unsupported-lambda-list 20 | #:get-non-bindings 21 | #:get-bindings 22 | #:binding-sym 23 | #:remove-&fn) 24 | (:import-from #:fiveam-matchers/core 25 | #:equal-to 26 | #:has-all 27 | #:is-not 28 | #:has-typep 29 | #:assert-that) 30 | (:import-from #:fiveam-matchers/lists 31 | #:contains)) 32 | (in-package :easy-macros/test-macros) 33 | 34 | 35 | (def-suite* :easy-macros/test-macros) 36 | 37 | (def-easy-macro with-basic-stuff (&fn fn) 38 | (funcall fn)) 39 | 40 | (def-easy-macro with-return-something-else (&fn fn) 41 | (funcall fn) 42 | :another) 43 | 44 | (test preconditions 45 | (is (equal :test 46 | (with-basic-stuff () 47 | :test))) 48 | (is (equal :another 49 | (with-return-something-else () 50 | :test)))) 51 | 52 | (def-easy-macro with-arg (add &fn fn) 53 | (+ add (funcall fn))) 54 | 55 | (test can-use-arguments 56 | 57 | (is (equal 5 (with-arg (1) 58 | 4))) 59 | 60 | (let ((value 45)) 61 | (is (equal 50 (with-arg (4) 62 | (+ 1 value)))))) 63 | 64 | (def-easy-macro with-eval-arg (add &fn fn) 65 | (+ add (funcall fn))) 66 | 67 | (test arguments-get-evaluated 68 | (let ((value 1)) 69 | (is (equal 5 (with-eval-arg (value) 70 | 4))))) 71 | 72 | (def-easy-macro with-multiple-args (one two &fn fn) 73 | (list one two)) 74 | 75 | (test multiple-arguments 76 | (is (equal (list :one :two) 77 | (with-multiple-args (:one :two) 78 | nil)))) 79 | 80 | (test remove-&fn 81 | (is (equal '(one two) (remove-&fn '(one two)))) 82 | (is (equal '(one two) (remove-&fn '(one &fn fn two)))) 83 | 84 | (assert-that (remove-&fn '(one &binding two)) 85 | (contains 86 | 'one 87 | (has-typep 'binding-sym)))) 88 | 89 | (test get-bindings 90 | (is (equal '(aaa) (get-bindings 91 | '(&binding one) 92 | '(aaa)))) 93 | (is (equal '(aaa) (get-bindings 94 | '(&binding one &key two) 95 | '(aaa)))) 96 | (is (equal '() (get-bindings 97 | '(one &key two) 98 | '(aaa :two 2))))) 99 | 100 | (test get-bindings-for-keys 101 | ;; Not that this would say &key foo, since this is the expression 102 | ;; that goes into the lamba-list for the user defined block 103 | (is (equal '(var) 104 | (get-bindings 105 | '(&key &binding foo) 106 | '(:foo var)))) 107 | (is (equal '(aaa bbb) (get-bindings 108 | '(&binding aaa &key &binding bbb) 109 | '(aaa :bbb bbb))))) 110 | 111 | (test get-non-bindings 112 | (is (equal '() (get-non-bindings 113 | '(&binding one) 114 | '(aaa)))) 115 | (is (equal '(2) (get-non-bindings 116 | '(&binding one two) 117 | '(aaa 2)))) 118 | (is (equal '(:foo 2) (get-non-bindings 119 | '(&binding one &key foo) 120 | '(aaa :foo 2))))) 121 | 122 | (test get-non-bindings-for-keys 123 | (is (equal '() (get-non-bindings 124 | '(&key &binding foo) 125 | '(:foo var)))) 126 | (is (equal '() (get-non-bindings 127 | '(&binding aaa &key &binding bbb) 128 | '(aaa :bbb bb)))) 129 | (is (equal '(:foo 2) 130 | (get-non-bindings 131 | '(&binding aaa &key &binding bbb foo) 132 | '(aaa :bbb bbb :foo 2))))) 133 | 134 | (test get-non-bindings-for-keys-with-defaults 135 | (is (equal '(:foo 2 :car 3) 136 | (get-non-bindings 137 | '(&binding aaa &key &binding bbb foo (car 3)) 138 | '(aaa :bbb bbb :foo 2 :car 3)))) 139 | (is (equal '(:foo 2 :car 3) 140 | (get-non-bindings 141 | '(&binding aaa &key &binding bbb foo (car (error "should not be called!"))) 142 | '(aaa :bbb bbb :foo 2 :car 3)))) 143 | (is (equal '(:foo 2) 144 | (get-non-bindings 145 | '(&binding aaa &key &binding bbb foo (car (error "should not be called!"))) 146 | '(aaa :bbb bbb :foo 2))))) 147 | 148 | (def-easy-macro with-bindings (&binding a &binding b &key one two 149 | &fn fn) 150 | (funcall fn 1 2)) 151 | 152 | (def-easy-macro with-bindings-v2 (&binding a &binding b &key one two 153 | &fn fn) 154 | (fn 1 2)) 155 | 156 | 157 | 158 | (test bindings 159 | (is (equal 3 160 | (with-bindings (aaa bbb) 161 | (+ aaa bbb)))) 162 | #+nil 163 | (signals unsupported-lambda-list 164 | (eval 165 | `(def-easy-macro with-key-bindings (&binding a &key &binding b) 166 | (funcall fn 1 3))))) 167 | 168 | (test bindings-v2 169 | (is (equal 3 170 | (with-bindings (aaa bbb) 171 | (+ aaa bbb)))) 172 | #+nil 173 | (signals unsupported-lambda-list 174 | (eval 175 | `(def-easy-macro with-key-bindings (&binding a &key &binding b) 176 | (funcall fn 1 3))))) 177 | 178 | 179 | (def-easy-macro with-key-bindings (&binding a &key &binding b one two 180 | &fn fn) 181 | (funcall fn 1 2)) 182 | 183 | 184 | (test bindings-with-keys 185 | (is (equal 3 186 | (with-key-bindings (aaa :b bbb) 187 | (+ aaa bbb))))) 188 | 189 | (def-easy-macro collect-loop (&binding item list &fn fn) 190 | (loop for x in list 191 | for i from 0 192 | collect (funcall fn x))) 193 | 194 | (test default-binding-example 195 | (is 196 | (equal '(2 4 6) 197 | (collect-loop (item '(1 2 3)) 198 | (* 2 item))))) 199 | 200 | (def-easy-macro collect-loop-with-index (&binding item list &key &binding index &fn fn) 201 | (loop for x in list 202 | for i from 0 203 | collect (funcall fn x i))) 204 | 205 | (test default-binding-example-with-index 206 | (is 207 | (equal '(0 2 6) 208 | (collect-loop-with-index (item '(1 2 3) :index i) 209 | (* item i)))) 210 | (is 211 | (equal '(1 2 3) 212 | (collect-loop-with-index (item '(1 2 3)) 213 | item)))) 214 | 215 | 216 | (def-easy-macro without-body (x) 217 | (+ 1 x)) 218 | 219 | (test no-&fn-provided 220 | (is (equal 3 (without-body (2)))) 221 | (is (equal 3 (without-body (2) 222 | (+ 4 5))))) 223 | 224 | (def-easy-macro without-body-but-with-binding (&binding item x) 225 | (+ 1 x)) 226 | 227 | (test no-&fn-provided-but-there-is-a-binding 228 | (is (equal 3 (without-body-but-with-binding (unused 2))))) 229 | 230 | (defun foobar () 231 | 1) 232 | 233 | (def-easy-macro with-some-defaults (&key (val (foobar))) 234 | (+ 1 val)) 235 | 236 | (defun call-the-macro () 237 | (+ 3 (with-some-defaults ()))) 238 | 239 | (test default-value-call-compiles () 240 | "This test would have failed at the compilation step, but we'll test 241 | the behavior anyway." 242 | (is (eql 5 (call-the-macro)))) 243 | 244 | (defun crashes () 245 | (error "should not be called")) 246 | 247 | (test build-funcall-with-defaults () 248 | (easy-macros::build-funcall 'call-with-some-defaults 249 | '(&key (val (crashes))) 250 | nil 251 | nil)) 252 | 253 | (defun find-defun (exprs) 254 | (loop for expr in exprs 255 | if (and 256 | (listp expr) 257 | (eql 'cl:defun (car expr))) 258 | return expr)) 259 | 260 | (test macroexpands-definition 261 | (let ((defun (find-defun 262 | (macroexpand-1 `(def-easy-macro foo () 263 | (declare (optimize speed))))))) 264 | (is (equal '(declare (optimize speed)) 265 | (fourth defun))))) 266 | 267 | (test macroexpands-definition-with-doc 268 | (let ((defun (find-defun 269 | (macroexpand-1 `(def-easy-macro foo () 270 | "foo" 271 | (declare (optimize speed))))))) 272 | (is (equal '(declare (optimize speed)) 273 | (fourth defun))))) 274 | --------------------------------------------------------------------------------