├── .github └── FUNDING.yml ├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── info.rkt ├── lang.rkt ├── main.rkt ├── scribblings ├── lang-template.rkt ├── template-includes.rkt └── template.scrbl └── tests ├── binding-forms.rkt ├── combiners.rkt ├── literals.rkt ├── module-templates.rkt ├── primitives.rkt └── scopes.rkt /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | github: dedbox 4 | patreon: dedbox 5 | ko_fi: dedbox 6 | liberapay: dedbox 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | doc/ 2 | compiled/ 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | 4 | branches: 5 | only: 6 | - master 7 | 8 | env: 9 | global: 10 | - RACKET_DIR=~/racket 11 | matrix: 12 | # - RACKET_VERSION=7.0 13 | # - RACKET_VERSION=7.1 14 | # - RACKET_VERSION=7.2 15 | - RACKET_VERSION=7.3 16 | - RACKET_VERSION=7.4 17 | - RACKET_VERSION=7.5 18 | - RACKET_VERSION=HEAD 19 | - RACKET_VERSION=HEADCS 20 | - RACKET_VERSION=RELEASE 21 | 22 | matrix: 23 | allow_failures: 24 | - env: RACKET_VERSION=HEAD 25 | - env: RACKET_VERSION=HEADCS 26 | - env: RACKET_VERSION=RELEASE 27 | fast_finish: true 28 | 29 | before_install: 30 | - git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket 31 | - cat ~/travis-racket/install-racket.sh | bash 32 | - export PATH="${RACKET_DIR}/bin:${PATH}" 33 | 34 | install: 35 | - raco pkg install --auto $TRAVIS_BUILD_DIR 36 | 37 | before_script: 38 | 39 | # Here supply steps such as raco make, raco test, etc. You can run 40 | # `raco pkg install --deps search-auto` to install any required 41 | # packages without it getting stuck on a confirmation prompt. 42 | script: 43 | - raco test -c template 44 | 45 | after_success: 46 | - raco setup --check-pkg-deps -p template 47 | - raco pkg install --deps search-auto cover cover-coveralls 48 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . 49 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Template Macros 2 | 3 | [![Racket Package](https://img.shields.io/badge/raco%20pkg-template-red.svg)](https://pkgd.racket-lang.org/pkgn/package/template) 4 | [![Documentation](https://img.shields.io/badge/read-docs-blue.svg)](http://docs.racket-lang.org/template/) 5 | [![Build Status](https://travis-ci.org/dedbox/racket-template.svg?branch=master)](https://travis-ci.org/dedbox/racket-template) 6 | [![Coverage Status](https://coveralls.io/repos/github/dedbox/racket-template/badge.svg?branch=master)](https://coveralls.io/github/dedbox/racket-template?branch=master) 7 | 8 | ## Dead Simple Code Generation for Racket 9 | 10 | Template macros combine the flexibility of [template 11 | meta-programming](https://en.wikipedia.org/wiki/Template_metaprogramming) with 12 | the safety of Racket's hygienic macro sub-system. 13 | 14 | Template variables are resolved *before* expansion by selectively rewriting 15 | the input text. The extra flexibility makes escaping to the expanding 16 | environment less necessary *and* more convenient. 17 | 18 | ``` racket 19 | #lang racket/base 20 | 21 | (require racket/match template (for-syntax racket/base)) 22 | 23 | (define-for-syntax the-fibs 24 | (make-immutable-hash 25 | (for/fold ([fibs '([1 . 1] [0 . 0])]) 26 | ([k (in-range 2 10)]) 27 | `([,k . ,(+ (cdar fibs) (cdadr fibs))] ,@fibs)))) 28 | 29 | (begin-template '#,(map cdr (sort (hash->list the-fibs) < #:key car))) 30 | ; '(0 1 1 2 3 5 8 13 21 34) 31 | 32 | (begin-template 33 | (define fib (match-lambda (for/template ([K (in-range 10)]) 34 | [K #,(hash-ref the-fibs K)])))) 35 | 36 | (fib 8) 37 | ; 21 38 | 39 | (fib 10) 40 | ; match-lambda: no matching clause for 10 41 | ``` 42 | 43 | ## Installation and Use 44 | 45 | Template macros are distributed in the 46 | [template](https://pkgs.racket-lang.org/package/template) package on the 47 | official Racket package repository. It can be installed from DrRacket's 48 | package manager, or with `raco pkg` from the comand line. 49 | 50 | ``` shell 51 | raco pkg install template 52 | ``` 53 | 54 | To start using template macros, import the `template` collection. 55 | 56 | ``` racket 57 | (require template) 58 | ``` 59 | 60 | See the [official documentation](https://docs.racket-lang.org/template/) for a 61 | detailed overview of template macros, along with a catalog of template 62 | constructors, combiners, and definers. 63 | 64 | ## Contributing 65 | 66 | Pull requests of any size are welcome. For help creating one, or to propose 67 | major changes, please open an 68 | [issue](https://github.com/dedbox/racket-template/issues/new) first to discuss 69 | what you would like to change. 70 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang info 16 | 17 | (define collection "template") 18 | (define deps '("base" "debug-scopes")) 19 | (define build-deps '("racket-doc" "rackunit-lib" "sandbox-lib" "scribble-lib")) 20 | (define scribblings '(("scribblings/template.scrbl"))) 21 | -------------------------------------------------------------------------------- /lang.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (require racket/base template) 18 | 19 | (provide (except-out (all-from-out racket/base) #%module-begin) 20 | (all-from-out template) 21 | (rename-out [template-module-begin #%module-begin])) 22 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (require debug-scopes 18 | racket/pretty 19 | racket/splicing 20 | syntax/parse/define 21 | (for-syntax debug-scopes 22 | racket/base 23 | racket/function 24 | racket/list 25 | racket/pretty 26 | racket/string 27 | racket/struct 28 | racket/syntax 29 | syntax/parse 30 | syntax/parse/define) 31 | (for-meta 2 racket/base) 32 | (for-template racket/base)) 33 | 34 | (provide untemplate untemplate-splicing define-templates define-template let-template 35 | letrec-template splicing-let-template splicing-letrec-template with-template 36 | semiwith-template quote-template semiquote-template begin-template 37 | begin0-template if-template cond-template when-template unless-template 38 | for/template for*/template template-module-begin load-template 39 | require-template require-templates debug-template debug-template/scopes 40 | reset-debug-scopes 41 | (for-syntax templates template semitemplates semitemplate quoted-templates 42 | quoted-template semiquoted-templates semiquoted-template)) 43 | 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | ;;; Binding Forms 46 | 47 | (begin-for-syntax 48 | (struct template (impl) 49 | #:transparent 50 | #:name _template 51 | #:constructor-name make-template 52 | #:property prop:procedure 0) 53 | 54 | (define-simple-macro (templates [(var:id ...) tpl ...] ...) 55 | (make-template 56 | (syntax-parser 57 | [(_ arg (... ...)) 58 | #:when (= (length (attribute arg)) 59 | (length (syntax->list #'(var ...)))) 60 | #:with (var* (... ...)) (map syntax-local-introduce (syntax->list #'(var ...))) 61 | #:with (tpl* (... ...)) (map syntax-local-introduce (syntax->list #'(tpl ...))) 62 | #'(with-template ([var* arg] (... ...)) (begin-template tpl* (... ...)))] 63 | ...))) 64 | 65 | (define-simple-macro (template (var:id ...) tpl ...) 66 | (templates [(var ...) tpl ...]))) 67 | 68 | (begin-for-syntax 69 | (define-simple-macro (semitemplates [(var:id ...) tpl ...] ...) 70 | (syntax-parser 71 | [(_ arg (... ...)) 72 | #:when (= (length (attribute arg)) 73 | (length (syntax->list #'(var ...)))) 74 | #:with (var* (... ...)) (map syntax-local-introduce (syntax->list #'(var ...))) 75 | #:with (tpl* (... ...)) (map syntax-local-introduce (syntax->list #'(tpl ...))) 76 | #'(semiwith-template ([var* arg] (... ...)) (begin-template tpl* (... ...)))] 77 | ...)) 78 | 79 | (define-simple-macro (semitemplate (var:id ...) tpl ...) 80 | (semitemplates [(var ...) tpl ...]))) 81 | 82 | (begin-for-syntax 83 | (define-simple-macro (quoted-templates [(var:id ...) tpl ...] ...) 84 | (syntax-parser 85 | [(_ arg (... ...)) 86 | #:when (= (length (attribute arg)) 87 | (length (syntax->list #'(var ...)))) 88 | #:with (var* (... ...)) (map syntax-local-introduce (syntax->list #'(var ...))) 89 | #:with (tpl* (... ...)) (map syntax-local-introduce (syntax->list #'(tpl ...))) 90 | #'(quote-template ([var* arg] (... ...)) (begin-template tpl* (... ...)))] 91 | ...)) 92 | 93 | (define-simple-macro (quoted-template (var:id ...) tpl ...) 94 | (quoted-templates [(var ...) tpl ...]))) 95 | 96 | (begin-for-syntax 97 | (define-simple-macro (semiquoted-templates [(var:id ...) tpl ...] ...) 98 | (syntax-parser 99 | [(_ arg (... ...)) 100 | #:when (= (length (attribute arg)) 101 | (length (syntax->list #'(var ...)))) 102 | #:with (var* (... ...)) (map syntax-local-introduce (syntax->list #'(var ...))) 103 | #:with (tpl* (... ...)) (map syntax-local-introduce (syntax->list #'(tpl ...))) 104 | #'(semiquote-template ([var* arg] (... ...)) (begin-template tpl* (... ...)))] 105 | ...)) 106 | 107 | (define-simple-macro (semiquoted-template (var:id ...) tpl ...) 108 | (semiquoted-templates [(var ...) tpl ...]))) 109 | 110 | (define-simple-macro (define-template (name:id var:id ...) tpl ...) 111 | (define-syntax name (template (var ...) tpl ...))) 112 | 113 | (define-simple-macro (define-templates [(name:id var:id ...) tpl ...] ...) 114 | (begin (define-template (name var ...) tpl ...) ...)) 115 | 116 | (define-simple-macro (let-template ([(name:id var:id ...) tpl ...] ...) body ...) 117 | (let-syntax ([name (template (var ...) tpl ...)] ...) (begin-template body ...))) 118 | 119 | (define-simple-macro (letrec-template ([(name:id var:id ...) tpl ...] ...) body ...) 120 | (letrec-syntax ([name (template (var ...) tpl ...)] ...) (begin-template body ...))) 121 | 122 | (define-simple-macro (splicing-let-template ([(name:id var:id ...) tpl ...] ...) body ...) 123 | (splicing-let-syntax ([name (template (var ...) tpl ...)] ...) body ...)) 124 | 125 | (define-simple-macro (splicing-letrec-template ([(name:id var:id ...) tpl ...] ...) body ...) 126 | (splicing-letrec-syntax ([name (template (var ...) tpl ...)] ...) body ...)) 127 | 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | ;;; Top-Level Templates 130 | 131 | (define-syntax-parser with-template 132 | [(_ ([var:id arg] ...) tpl ...) 133 | (syntax-local-introduce 134 | (null-voided 135 | #'begin 136 | (resolve-with (map syntax-local-introduce (attribute var)) 137 | (attribute arg) 138 | (map syntax-local-introduce (attribute tpl)))))]) 139 | 140 | (define-syntax-parser semiwith-template 141 | [(_ ([var:id arg] ...) tpl ...) 142 | (syntax-local-introduce 143 | (null-voided 144 | #'begin 145 | (resolve-semiwith (map syntax-local-introduce (attribute var)) 146 | (attribute arg) 147 | (map syntax-local-introduce (attribute tpl)))))]) 148 | 149 | (define-syntax-parser quote-template 150 | [(_ ([var:id arg] ...) tpl ...) 151 | (syntax-local-introduce 152 | (null-voided 153 | #'begin 154 | (resolve-quote (map syntax-local-introduce (attribute var)) 155 | (attribute arg) 156 | (map syntax-local-introduce (attribute tpl)))))]) 157 | 158 | (define-syntax-parser semiquote-template 159 | [(_ ([var:id arg] ...) tpl ...) 160 | (syntax-local-introduce 161 | (null-voided 162 | #'begin 163 | (resolve-semiquote (map syntax-local-introduce (attribute var)) 164 | (attribute arg) 165 | (map syntax-local-introduce (attribute tpl)))))]) 166 | 167 | (define-syntax-parser begin-template 168 | [(_ tpl ...) 169 | (syntax-local-introduce 170 | (null-voided 171 | #'begin 172 | (resolve-with null null (map syntax-local-introduce (attribute tpl)))))]) 173 | 174 | (define-syntax-parser begin0-template 175 | [(_ tpl ...) 176 | (syntax-local-introduce 177 | (null-voided 178 | #'begin0 179 | (resolve-with null null (map syntax-local-introduce (attribute tpl)))))]) 180 | 181 | (define-syntax-parser if-template 182 | [(_ test pass-tpl fail-tpl) 183 | (syntax-local-introduce 184 | (null-voided 185 | #'begin 186 | (resolve-if (syntax-local-introduce (attribute test)) 187 | (syntax-local-introduce (attribute pass-tpl)) 188 | (syntax-local-introduce (attribute fail-tpl)))))]) 189 | 190 | (begin-for-syntax 191 | (define-syntax-class not-else (pattern (~not (~literal else))))) 192 | 193 | (define-syntax-parser cond-template 194 | [(_ [test:not-else then-tpl ...] ... 195 | (~optional [(~literal else) else-tpl ...])) 196 | (syntax-local-introduce 197 | (null-voided 198 | #'begin 199 | (resolve-cond (map syntax-local-introduce (attribute test)) 200 | (map (curry map syntax-local-introduce) (attribute then-tpl)) 201 | (and (attribute else-tpl) 202 | (map syntax-local-introduce (attribute else-tpl))))))]) 203 | 204 | (define-syntax-parser when-template 205 | [(_ test-expr tpl ...) 206 | (syntax-local-introduce 207 | (null-voided 208 | #'begin 209 | (resolve-when (syntax-local-introduce (attribute test-expr)) 210 | (map syntax-local-introduce (attribute tpl)))))]) 211 | 212 | (define-syntax-parser unless-template 213 | [(_ test-expr tpl ...) 214 | (syntax-local-introduce 215 | (null-voided 216 | #'begin 217 | (resolve-unless (syntax-local-introduce (attribute test-expr)) 218 | (map syntax-local-introduce (attribute tpl)))))]) 219 | 220 | (define-syntax-parser for/template 221 | [(_ ([var:id seq] ...) tpl ...) 222 | (syntax-local-introduce 223 | (null-voided 224 | #'begin 225 | (resolve-comprehension #'for/list 226 | (map syntax-local-introduce (attribute var)) 227 | (map syntax-local-introduce (attribute seq)) 228 | (map syntax-local-introduce (attribute tpl)))))]) 229 | 230 | (define-syntax-parser for*/template 231 | [(_ ([var:id seq] ...) tpl ...) 232 | (syntax-local-introduce 233 | (null-voided 234 | #'begin 235 | (resolve-comprehension #'for*/list 236 | (map syntax-local-introduce (attribute var)) 237 | (map syntax-local-introduce (attribute seq)) 238 | (map syntax-local-introduce (attribute tpl)))))]) 239 | 240 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 241 | ;;; Sub-Templates 242 | 243 | (define-for-syntax (resolve-syntax-object stx) 244 | (parameterize ([current-resolvers (cons resolve-syntax (current-resolvers))]) 245 | (with-syntax ([tpl (resolve-one stx)]) #'#'tpl))) 246 | 247 | (define-for-syntax (resolve-quasisyntax-object stx) 248 | (parameterize ([current-resolvers (cons resolve-quasisyntax (current-resolvers))]) 249 | (with-syntax ([tpl (resolve-one stx)]) #'#`tpl))) 250 | 251 | (define-for-syntax (resolve-unsyntax-object stx) 252 | (parameterize ([current-resolvers (cdr (current-resolvers))]) 253 | (with-syntax ([tpl (resolve-one stx)]) #'#,tpl))) 254 | 255 | (define-for-syntax (resolve-unsyntax-splicing-object stx) 256 | (parameterize ([current-resolvers (cdr (current-resolvers))]) 257 | (with-syntax ([tpl (resolve-one stx)]) #'#,@tpl))) 258 | 259 | (define-for-syntax (resolve-untemplate stx) 260 | (parameterize ([current-resolvers (cdr (current-resolvers))]) 261 | (resyntax stx (syntax-local-eval (resolve-one stx))))) 262 | 263 | (define-for-syntax (resolve-untemplate-splicing stx) 264 | (define results 265 | (parameterize ([current-resolvers (cdr (current-resolvers))]) 266 | (for/list ([result (in-list (map syntax-local-eval (resolve stx)))]) 267 | (if (list? result) result (syntax-e result))))) 268 | (map (curry resyntax stx) (flatten results))) 269 | 270 | (define-for-syntax (resolve-app stx) 271 | (define stxs (syntax->list stx)) 272 | (let* ([head (resolve (car stxs))] 273 | [tpl (and (pair? head) 274 | (identifier? (car head)) 275 | (syntax-local-value (car head) (λ _ #f)))]) 276 | (if (template? tpl) 277 | (let ([results (resolve (tpl stx))]) 278 | (if (and (pair? results) (null? (cdr results))) 279 | (syntax-parse (car results) 280 | [((~literal void)) null] 281 | [((~literal begin) t ...) (attribute t)] 282 | [_ results]) 283 | results)) 284 | (list (resyntax stx (append head (resolve-many (cdr stxs)))))))) 285 | 286 | (define-for-syntax (resolve-pair stx) 287 | (define stxs (syntax-e stx)) 288 | (define head (resolve-one (car stxs))) 289 | (define tail 290 | (cond [(pair? (cdr stxs)) (car (resolve-pair (resyntax stx (cdr stxs))))] 291 | [(syntax? (cdr stxs)) (resolve-one (cdr stxs))] 292 | [else (error 'impossible)])) 293 | (define tail* (if ((disjoin pair? null?) (syntax-e tail)) (syntax-e tail) tail)) 294 | (list (resyntax stx (cons head tail*)))) 295 | 296 | (define-for-syntax (resolve-with vars args tpls) 297 | (parameterize ([current-vars (append vars (current-vars))] 298 | [current-args (append (map resolve-one args) (current-args))] 299 | [current-resolvers (cons resolve-template (current-resolvers))] 300 | [keep-template-scopes? #t] 301 | [resolve-inside-syntax? #t] 302 | [resolve-outside-syntax? #t]) 303 | (resolve-many tpls))) 304 | 305 | (define-for-syntax (resolve-semiwith vars args tpls) 306 | (parameterize ([current-vars (append vars (current-vars))] 307 | [current-args (append (map resolve-one args) (current-args))] 308 | [current-resolvers (cons resolve-template (current-resolvers))] 309 | [keep-template-scopes? #f] 310 | [resolve-inside-syntax? #t] 311 | [resolve-outside-syntax? #t]) 312 | (resolve-many tpls))) 313 | 314 | (define-for-syntax (resolve-quote vars args tpls) 315 | (parameterize ([current-vars (append vars (current-vars))] 316 | [current-args (append (map resolve-one args) (current-args))] 317 | [current-resolvers (cons resolve-quote-template (current-resolvers))] 318 | [keep-template-scopes? #f] 319 | [resolve-inside-syntax? #f] 320 | [resolve-outside-syntax? #f]) 321 | (resolve-many tpls))) 322 | 323 | (define-for-syntax (resolve-semiquote vars args tpls) 324 | (parameterize ([current-vars (append vars (current-vars))] 325 | [current-args (append (map resolve-one args) (current-args))] 326 | [current-resolvers (cons resolve-quote-template (current-resolvers))] 327 | [keep-template-scopes? #t] 328 | [resolve-inside-syntax? #f] 329 | [resolve-outside-syntax? #f]) 330 | (resolve-many tpls))) 331 | 332 | (define-for-syntax (resolve-if test pass fail) 333 | (resolve (if (syntax-local-eval (resolve-one test)) pass fail))) 334 | 335 | (define-for-syntax (resolve-cond tests then-tpls else-tpls) 336 | (resolve-many (or (for/or ([stx (in-list tests)] 337 | [tpls (in-list then-tpls)]) 338 | (and (syntax-local-eval (resolve-one stx)) tpls)) 339 | else-tpls null))) 340 | 341 | (define-for-syntax (resolve-when test tpls) 342 | (resolve-many (if (syntax-local-eval (resolve-one test)) tpls null))) 343 | 344 | (define-for-syntax (resolve-unless test tpls) 345 | (resolve-many (if (syntax-local-eval (resolve-one test)) null tpls))) 346 | 347 | (define-for-syntax (resolve-comprehension for/? vars seqs tpls) 348 | (define-values (ctx args-list) 349 | (syntax-local-eval 350 | (with-syntax ([(var ...) vars] 351 | [(seq ...) (parameterize ([keep-template-scopes? #t]) 352 | (resolve-many seqs))]) 353 | #`(values #'ctx (#,for/? ([var seq] ...) 354 | (map datum->syntax (list #'var ...) (list var ...))))))) 355 | (define rescope (curryr (make-syntax-delta-introducer ctx #'here) 'remove)) 356 | (define tpls* 357 | (parameterize ([current-resolvers (cons resolve-quote-template (current-resolvers))] 358 | [resolve-inside-syntax? #f] 359 | [resolve-outside-syntax? #f]) 360 | (resolve-many tpls))) 361 | (parameterize ([current-vars (append vars (current-vars))] 362 | [current-comps (append vars (current-comps))] 363 | [keep-template-scopes? #t]) 364 | (flatten 365 | (for/list ([args (in-list args-list)]) 366 | (parameterize ([current-args (append (map rescope args) (current-args))]) 367 | (resolve-many tpls*)))))) 368 | 369 | (define-for-syntax (null-voided head stxs) 370 | (cond [(null? stxs) #'(void)] 371 | [(null? (cdr stxs)) (car stxs)] 372 | [else #`(#,head #,@stxs)])) 373 | 374 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 375 | ;;; Template Constructors 376 | 377 | (define-syntax (untemplate stx) 378 | (raise-syntax-error #f "illegal outside of template macro" stx)) 379 | 380 | (define-syntax (untemplate-splicing stx) 381 | (raise-syntax-error #f "illegal outside of template macro" stx)) 382 | 383 | (begin-for-syntax 384 | (define-syntax-class vector-t (pattern _ #:when (vector? (syntax-e this-syntax)))) 385 | (define-syntax-class box-t (pattern _ #:when (box? (syntax-e this-syntax)))) 386 | (define-syntax-class hash-t (pattern _ #:when (hash? (syntax-e this-syntax)))) 387 | (define-syntax-class prefab-t (pattern _ #:when (struct? (syntax-e this-syntax)))) 388 | (define-syntax-class literal 389 | (pattern (~or :id :boolean :char :keyword :number :regexp :byte-regexp :str :bytes))) 390 | (define-literal-set template-forms 391 | (untemplate untemplate-splicing with-template semiwith-template quote-template 392 | semiquote-template begin-template begin0-template if-template 393 | cond-template when-template unless-template for/template for*/template 394 | let-template)) 395 | 396 | (define-simple-macro (either inside-expr not-inside-expr) 397 | (if (resolve-inside-syntax?) inside-expr not-inside-expr)) 398 | 399 | (define-simple-macro (maybe expr) 400 | #:with this-syntax (datum->syntax this-syntax 'this-syntax) 401 | (either expr (resolve-app this-syntax)))) 402 | 403 | (define-for-syntax resolve-template 404 | (syntax-parser 405 | #:literals (syntax quasisyntax unsyntax unsyntax-splicing) 406 | #:literal-sets (template-forms) 407 | [ (syntax tpl) (list (resolve-syntax-object (attribute tpl)))] 408 | [(quasisyntax tpl) (list (resolve-quasisyntax-object (attribute tpl)))] 409 | [ (unsyntax tpl) (list (resolve-untemplate (attribute tpl)))] 410 | [(unsyntax-splicing tpl) (resolve-untemplate-splicing (attribute tpl))] 411 | [(untemplate tpl) (list (resolve-untemplate (attribute tpl)))] 412 | [(untemplate-splicing tpl) (resolve-untemplate-splicing (attribute tpl))] 413 | [(begin-template tpl ...) (resolve-with null null (attribute tpl))] 414 | [(with-template ([var:id arg] ...) tpl ...) 415 | (resolve-with (attribute var) (attribute arg) (attribute tpl))] 416 | [(semiwith-template ([var:id arg] ...) tpl ...) 417 | (resolve-semiwith (attribute var) (attribute arg) (attribute tpl))] 418 | [(quote-template ([var:id arg] ...) tpl ...) 419 | (resolve-quote (attribute var) (attribute arg) (attribute tpl))] 420 | [(semiquote-template ([var:id arg] ...) tpl ...) 421 | (resolve-semiquote (attribute var) (attribute arg) (attribute tpl))] 422 | [(if-template test pass fail) 423 | (resolve-if (attribute test) (attribute pass) (attribute fail))] 424 | [(cond-template [test:not-else then-tpl ...] ... 425 | (~optional [(~literal else) else-tpl ...])) 426 | (resolve-cond (attribute test) (attribute then-tpl) (attribute else-tpl))] 427 | [ (when-template test tpl ...) (resolve-when (attribute test) (attribute tpl))] 428 | [(unless-template test tpl ...) (resolve-unless (attribute test) (attribute tpl))] 429 | [(for/template ([var:id seq] ...) tpl ...) 430 | (resolve-comprehension #'for/list 431 | (attribute var) 432 | (attribute seq) 433 | (attribute tpl))] 434 | [(for*/template ([var:id seq] ...) tpl ...) 435 | (resolve-comprehension #'for*/list 436 | (attribute var) 437 | (attribute seq) 438 | (attribute tpl))] 439 | [_ (resolve-quote-template this-syntax)])) 440 | 441 | (define-for-syntax resolve-quasisyntax 442 | (syntax-parser 443 | #:literals (syntax quasisyntax unsyntax unsyntax-splicing) 444 | #:literal-sets (template-forms) 445 | [ (syntax tpl) (list (resolve-syntax-object (attribute tpl)))] 446 | [(quasisyntax tpl) (list (resolve-quasisyntax-object (attribute tpl)))] 447 | [ (unsyntax tpl) (list (resolve-unsyntax-object (attribute tpl)))] 448 | [ (unsyntax-splicing tpl) (list (resolve-unsyntax-splicing-object (attribute tpl)))] 449 | [_ (resolve-syntax this-syntax)])) 450 | 451 | (define-for-syntax resolve-syntax 452 | (syntax-parser 453 | #:literal-sets (template-forms) 454 | [(untemplate tpl) (maybe (list (resolve-untemplate (attribute tpl))))] 455 | [(untemplate-splicing tpl) (maybe (resolve-untemplate-splicing (attribute tpl)))] 456 | [(begin-template tpl ...) (maybe (resolve-with null null (attribute tpl)))] 457 | [(with-template ([var:id arg] ...) tpl ...) 458 | (maybe (resolve-with (attribute var) (attribute arg) (attribute tpl)))] 459 | [(semiwith-template ([var:id arg] ...) tpl ...) 460 | (maybe (resolve-semiwith (attribute var) (attribute arg) (attribute tpl)))] 461 | [(quote-template ([var:id arg] ...) tpl ...) 462 | (maybe (resolve-quote (attribute var) (attribute arg) (attribute tpl)))] 463 | [(semiquote-template ([var:id arg] ...) tpl ...) 464 | (maybe (resolve-semiquote (attribute var) (attribute arg) (attribute tpl)))] 465 | [(if-template test pass fail) 466 | (maybe (resolve-if (attribute test) (attribute pass) (attribute fail)))] 467 | [(cond-template [test:not-else then-tpl ...] ... 468 | (~optional [(~literal else) else-tpl ...])) 469 | (maybe (resolve-cond (attribute test) (attribute then-tpl) (attribute else-tpl)))] 470 | [ (when-template test tpl ...) (maybe (resolve-when (attribute test) (attribute tpl)))] 471 | [(unless-template test tpl ...) (maybe (resolve-unless (attribute test) (attribute tpl)))] 472 | [(for/template ([var:id seq] ...) tpl ...) 473 | (maybe (resolve-comprehension #'for/list 474 | (attribute var) 475 | (attribute seq) 476 | (attribute tpl)))] 477 | [(for*/template ([var:id seq] ...) tpl ...) 478 | (maybe (resolve-comprehension #'for*/list 479 | (attribute var) 480 | (attribute seq) 481 | (attribute tpl)))] 482 | [_ (resolve-quote-template this-syntax)])) 483 | 484 | (define-for-syntax resolve-quote-template 485 | (syntax-parser 486 | #:literal-sets (template-forms) 487 | [() (list this-syntax)] 488 | [(_ ...) (resolve-app this-syntax)] 489 | [(_ . _) (list (resolve-pair this-syntax))] 490 | [:vector-t (list (resolve-vector this-syntax))] 491 | [:box-t (list (resolve-box this-syntax))] 492 | [:hash-t (list (resolve-hash this-syntax))] 493 | [:prefab-t (list (resolve-prefab this-syntax))] 494 | [:literal (list (resolve-literal this-syntax))] 495 | [_ (list this-syntax)])) 496 | 497 | (define-for-syntax current-vars (make-parameter null)) 498 | (define-for-syntax current-args (make-parameter null)) 499 | (define-for-syntax current-comps (make-parameter null)) 500 | (define-for-syntax current-resolvers (make-parameter (build-list 2 (λ _ resolve-template)))) 501 | (define-for-syntax keep-template-scopes? (make-parameter #t)) 502 | (define-for-syntax resolve-inside-syntax? (make-parameter #t)) 503 | (define-for-syntax resolve-outside-syntax? (make-parameter #t)) 504 | 505 | (define-for-syntax (resolve stx) 506 | ((car (current-resolvers)) stx)) 507 | 508 | (define-for-syntax (resolve-one stx) 509 | (define results (resolve stx)) 510 | (cond [(null? results) 511 | (raise-syntax-error 512 | #f "no template generated for single-template context" stx)] 513 | [(null? (cdr results)) (car results)] 514 | [else 515 | (raise-syntax-error 516 | #f "multiple templates generated for single-template context" stx)])) 517 | 518 | (define-for-syntax (resolve-many stxs) 519 | (flatten (map resolve stxs))) 520 | 521 | (define-for-syntax (resyntax ctx val) 522 | (datum->syntax ctx val ctx ctx)) 523 | 524 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 525 | ;;; Literal Forms 526 | 527 | (define-for-syntax (resolve-vector stx) 528 | ((resolve-special-syntax stx) (compose list->vector resolve-many vector->list))) 529 | 530 | (define-for-syntax (resolve-box stx) 531 | ((resolve-special-syntax stx) (compose (curry apply box-immutable) resolve unbox))) 532 | 533 | (define-for-syntax (resolve-hash stx) 534 | ((resolve-special-syntax stx) 535 | (λ (H) 536 | ((cond [(hash-eq? H) make-immutable-hasheq ] 537 | [(hash-eqv? H) make-immutable-hasheqv] 538 | [else make-immutable-hash]) 539 | (for/list ([(key val) (in-hash H)]) 540 | (cons (syntax->datum (resolve-one (datum->syntax #f key))) 541 | (resolve-one val))))))) 542 | 543 | (define-for-syntax (resolve-prefab stx) 544 | ((resolve-special-syntax stx) 545 | (λ (P) 546 | (define key (resolve-one (prefab-struct-key P))) 547 | (apply make-prefab-struct 548 | (syntax->datum (resolve-one (datum->syntax #f key))) 549 | (resolve-many (struct->list P)))))) 550 | 551 | (define-for-syntax ((resolve-special-syntax stx) handler) 552 | (if (has-template-vars? (syntax->string stx)) 553 | (resyntax stx (handler (syntax-e stx))) 554 | stx)) 555 | 556 | (define-for-syntax (resolve-literal stx) 557 | (define str (syntax->string stx)) 558 | (define x0 (has-template-vars? str)) 559 | (define str* 560 | (and x0 (let ([str* (resolve-vars str)]) 561 | (cond [(string=? str* "") "||"] 562 | [(and (identifier-string? str*) (string-contains? str* " ")) 563 | (format "|~a|" str*)] 564 | [else str*])))) 565 | (if str* 566 | (if (or (keep-template-scopes?) (is-comp? x0)) 567 | (string->syntax stx str*) 568 | (string->syntax (var-arg str) str*)) 569 | stx)) 570 | 571 | (define-for-syntax (identifier-string? str) 572 | (or (char=? (string-ref str 0) #\|) 573 | (not (or (char=? (string-ref str 0) #\") 574 | (char=? (string-ref str 0) #\() 575 | (and (char=? (string-ref str 0) #\#) 576 | (not (char=? (string-ref str 1) #\%))))))) 577 | 578 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 579 | ;;; Template Variables 580 | 581 | (define-for-syntax (has-template-vars? str) 582 | (for/or ([var (in-list (current-vars))]) 583 | (and (has-var? str var) var))) 584 | 585 | (define-for-syntax (has-var? str var) 586 | (string-contains? str (syntax->string var))) 587 | 588 | (define-for-syntax (is-comp? var) 589 | (and var (member (syntax->string var) 590 | (map syntax->string (current-comps)) 591 | string=?))) 592 | 593 | (define-for-syntax (var-arg str) 594 | (for/or ([var (in-list (current-vars))] 595 | [arg (in-list (current-args))]) 596 | (and (has-var? str var) (syntax-local-introduce arg)))) 597 | 598 | (define-for-syntax (resolve-vars str) 599 | (for/fold ([str str]) 600 | ([x (in-list (map syntax->string (current-vars)))] 601 | [a (in-list (map syntax->string (current-args)))]) 602 | (string-replace str x a))) 603 | 604 | (define-for-syntax syntax->string 605 | (syntax-parser 606 | [(~datum ||) ""] 607 | [(a ...) (format "(~a)" (string-join (map syntax->string (attribute a))))] 608 | [:id (format "~a" (syntax->datum this-syntax))] 609 | [_ (format "~s" (syntax->datum this-syntax))])) 610 | 611 | (define-for-syntax (string->syntax ctx str) 612 | (define port (open-input-string str)) 613 | (define datum (read port)) 614 | (begin0 (resyntax ctx (if (eof-object? datum) '|| datum)) 615 | (unless (eof-object? (read port)) 616 | (raise-syntax-error 617 | #f "multiple expressions generated for single-expression context" ctx)))) 618 | 619 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 620 | ;;; Module Templates 621 | 622 | (define-simple-macro (template-module-begin (var:id ...) tpl ...) 623 | #:with template-arity #`#,(length (attribute var)) 624 | #:with ((spec ...) (tpl* ...)) 625 | (call-with-values 626 | (λ () 627 | (for/fold ([specs null] 628 | [tpls null]) 629 | ([stx (in-list (attribute tpl))]) 630 | (syntax-parse stx 631 | [((~literal require) spec ...) (values (append specs (attribute spec)) tpls)] 632 | [_ (values specs (append tpls (list stx)))]))) 633 | list) 634 | 635 | (#%module-begin 636 | (require template (for-syntax racket/base) spec ...) 637 | (provide the-template) 638 | 639 | (define-for-syntax (rescope ctx) 640 | (compose 641 | (curryr (make-syntax-delta-introducer ctx #f) 'add) 642 | (curryr (make-syntax-delta-introducer #'template-module-begin #f) 'remove))) 643 | 644 | (define-syntax (the-template stx) 645 | (syntax-case stx () 646 | [(_ arg (... ...)) 647 | (= (length (syntax->list #'(arg (... ...)))) template-arity) 648 | (with-syntax ([(var* (... ...)) ((rescope stx) #'(var ...))]) 649 | #'(semiwith-template ([var* arg] (... ...)) tpl* ...))])))) 650 | 651 | (define-simple-macro (load-template mod-path name:id) 652 | #:with the-template (datum->syntax this-syntax 'the-template) 653 | (local-require (rename-in mod-path [the-template name]))) 654 | 655 | (define-simple-macro (require-template mod-path name:id) 656 | #:with the-template (datum->syntax this-syntax 'the-template) 657 | (require (rename-in mod-path [the-template name]))) 658 | 659 | (define-simple-macro (require-templates [mod-path name:id] ...) 660 | #:with the-template (datum->syntax this-syntax 'the-template) 661 | (require (rename-in mod-path [the-template name]) ...)) 662 | 663 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 664 | ;;; #lang template 665 | 666 | (module reader syntax/module-reader template/lang) 667 | 668 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 669 | ;;; Developer Tools 670 | 671 | (define-simple-macro (debug-template tpl) 672 | #:with tpl* (local-expand (attribute tpl) 'top-level #f) 673 | (begin (pretty-write 'tpl*) tpl*)) 674 | 675 | (define-simple-macro (debug-template/scopes tpl) 676 | #:with tpl* (syntax-disarm (local-expand (attribute tpl) 'top-level (list #'syntax)) #f) 677 | (begin (displayln (+scopes #'tpl*)) (print-full-scopes #f) tpl*)) 678 | 679 | (define-simple-macro (reset-debug-scopes) 680 | (parameterize ([current-output-port (open-output-string)]) 681 | (print-full-scopes))) 682 | -------------------------------------------------------------------------------- /scribblings/lang-template.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang template ($x $n) 16 | 17 | (require (for-syntax racket/base)) 18 | 19 | (define $xs '((for/template ([$_ (in-range 1 (add1 $n))]) $x))) 20 | 21 | (for/template ([$k (in-range 1 (add1 $n))]) 22 | (define $x$k $k)) 23 | -------------------------------------------------------------------------------- /scribblings/template-includes.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (require racket/sandbox 18 | scribble/example 19 | scribble/manual) 20 | 21 | (provide (all-defined-out)) 22 | 23 | (define (rtech . args) 24 | (apply tech #:doc '(lib "scribblings/reference/reference.scrbl") args)) 25 | 26 | (define (gtech . args) 27 | (apply tech #:doc '(lib "scribblings/guide/guide.scrbl") args)) 28 | 29 | (define template-evaluator 30 | (call-with-trusted-sandbox-configuration 31 | (λ () 32 | (parameterize ([sandbox-output 'string] 33 | [sandbox-error-output 'string]) 34 | (make-base-eval #:lang 'racket/base '(void)))))) 35 | 36 | (define-syntax-rule (example expr ...) 37 | (examples #:eval template-evaluator 38 | #:label #f 39 | #:preserve-source-locations 40 | expr ...)) 41 | 42 | (define-syntax-rule (EXAMPLE expr ...) 43 | (examples #:eval template-evaluator 44 | #:escape UNSYNTAX 45 | #:label #f 46 | #:preserve-source-locations 47 | expr ...)) 48 | -------------------------------------------------------------------------------- /scribblings/template.scrbl: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang scribble/manual 16 | 17 | @title{Template Macros} 18 | @author{@author+email["Eric Griffis" "dedbox@gmail.com"]} 19 | 20 | @require{./template-includes.rkt} 21 | 22 | @require[ 23 | @for-syntax[ 24 | racket/base 25 | racket/file 26 | racket/function 27 | racket/runtime-path 28 | racket/syntax 29 | ] 30 | @for-label[ 31 | debug-scopes 32 | racket/base 33 | racket/contract 34 | racket/function 35 | racket/sequence 36 | racket/syntax 37 | template 38 | ] 39 | ] 40 | 41 | @example[#:hidden 42 | @require[ 43 | racket/contract 44 | racket/function 45 | template 46 | @for-syntax[ 47 | racket/base 48 | racket/sequence 49 | ] 50 | ] 51 | ] 52 | 53 | @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | @defmodule[template] 56 | 57 | @section{Overview} 58 | 59 | @deftech{Template macros} are similar to @gtech{pattern-based macros}, but 60 | with four important differences: 61 | 62 | @itemlist[ 63 | 64 | @item{Template variables are resolved @emph{within} every internable datum 65 | and can be combined to synthesize non-identifier literals. 66 | 67 | @example[ 68 | (with-template ([$x 3] [$y 2]) (add1 $x$y0)) 69 | ]} 70 | 71 | @item{Template variables are @emph{always} in scope, regardless of 72 | position, quoting depth, or escape level. 73 | 74 | @example[ 75 | (begin-template '((for/template ([$a 3]) #'"$a"))) 76 | ] 77 | } 78 | 79 | @item{Most templates become splicing forms when used inside other templates. 80 | 81 | @example[ 82 | (begin-template (list (for/template ([$k 10]) (add1 $k)))) 83 | ]} 84 | 85 | @item{Templates can escape to the expanding environment, even when they 86 | appear @emph{outside} of a @rtech{syntax transformer}. 87 | 88 | @example[ 89 | (begin-template '(#,@(list #'hello #'world))) 90 | ]} 91 | 92 | ] 93 | 94 | The @racketmodname[template] API splits ordinary macro @rtech{expansion} into 95 | two distinct stages: @deftech{template expansion} time and @deftech{macro 96 | expansion} time. Always, template variables are resolved and sub-template 97 | forms are expanded before ordinary macros are expanded. 98 | 99 | @subsection{The `@racketid[$]' Convention} 100 | 101 | Throughout this manual, the names of template variables start with a 102 | `@racketid[$]'. Although the @racketmodname[template] API imposes no such 103 | restriction on variable names, beware: 104 | 105 | @tech{Template macro} variable resolution is finer-grained than ordinary 106 | variable resolution. Poorly chosen variable names can lead to bizarre syntax 107 | errors. 108 | 109 | Examples: 110 | @example[ 111 | (eval:error (with-template ([e X]) (define e 123))) 112 | (eval:error (with-template ([e X]) 'e)) 113 | ] 114 | 115 | @; ----------------------------------------------------------------------------- 116 | 117 | @section{Primitives} 118 | 119 | @defform[(with-template ([var-id val-expr] ...) tpl ...)]{ 120 | 121 | Expands the sub-templates of the @var[tpl]s and substitutes @var[var-id]s 122 | with @var[val-expr]s while retaining the @rtech{lexical information}, 123 | source-location information, and @rtech{syntax properties} of the 124 | originating template source. 125 | 126 | Example: 127 | @example[ 128 | (with-template ([$x a] 129 | [$y b]) 130 | (define $xs '($x $x $x)) 131 | (displayln `($xs = ,@$xs))) 132 | ] 133 | 134 | When a @racket[with-template] form appears at the top level, at module 135 | level, or in an internal-definition position (before any expression in the 136 | internal-definition sequence), it is equivalent to splicing the expanded 137 | @var[tpl]s into the enclosing context. 138 | 139 | Examples: 140 | @example[ 141 | (with-template ([$x a] 142 | [$y b]) 143 | (define ($x-$y? obj) 144 | (equal? obj '($x $y)))) 145 | (a-b? '(a b)) 146 | (a-b? '(c d)) 147 | (list 148 | (with-template ([$x a]) '$x) 149 | (with-template ([$x b]) '$x)) 150 | ] 151 | } 152 | 153 | @defform[(semiwith-template ([var-id val-expr] ...) tpl ...)]{ 154 | 155 | Like @racket[with-template], except literals generated from template 156 | variables inherit the @rtech{lexical information}, source-location 157 | information, and @rtech{syntax properties} of the @var[val-expr] bound to 158 | the first @var[var-id] used. 159 | 160 | Example: 161 | @example[ 162 | (semiwith-template ([$where here]) #'$where) 163 | ] 164 | 165 | @example[ 166 | (with-template ([$where not-here]) #'$where) 167 | ] 168 | } 169 | 170 | @defform[(quote-template ([var-id val-expr] ...) tpl ...)]{ 171 | 172 | Like @racket[semiwith-template], except sub-templates are not expanded. 173 | 174 | Example: 175 | @example[ 176 | (quote-template ([$where not-here]) #'(untemplate '$where)) 177 | ] 178 | 179 | @example[ 180 | (semiwith-template ([$where there]) #'(untemplate '$where)) 181 | ] 182 | } 183 | 184 | @defform[(semiquote-template ([var-id val-expr] ...) tpl ...)]{ 185 | 186 | Like @racket[quote-template], except literals generated from template 187 | variables inherit the @rtech{lexical information}, source-location 188 | information, and @rtech{syntax properties} of the @var[val-expr] bound to 189 | the first @var[var-id] used. 190 | 191 | Example: 192 | @example[ 193 | (semiquote-template ([$where not-here]) #'(untemplate '$where)) 194 | ] 195 | 196 | @example[ 197 | (quote-template ([$where not-here]) #'(untemplate '$where)) 198 | ] 199 | } 200 | 201 | @; ----------------------------------------------------------------------------- 202 | 203 | @section{Constructors} 204 | 205 | @deftogether[( 206 | @defform[(template (var-id ...) tpl ...)] 207 | @defform[(semitemplate (var-id ...) tpl ...)] 208 | @defform[(quoted-template (var-id ...) tpl ...)] 209 | @defform[(semiquoted-template (var-id ...) tpl ...)] 210 | )]{ 211 | 212 | Produces a @tech{template macro} procedure; a @rtech{syntax transformer} for 213 | a macro that accepts an argument for each @var[var-id] and substitutes them 214 | into the @var[tpl]s. 215 | 216 | Example: 217 | @example[ 218 | (define-syntax iterate-with 219 | (template ($for) 220 | ($for/list ([x (in-range 3)] 221 | [y (in-range 3)]) 222 | (+ y (* x 3))))) 223 | (iterate-with for) 224 | (iterate-with for*) 225 | ] 226 | } 227 | 228 | @deftogether[( 229 | @defform[(templates [(var-id ...) tpl ...] ...)] 230 | @defform[(semitemplates [(var-id ...) tpl ...] ...)] 231 | @defform[(quoted-templates [(var-id ...) tpl ...] ...)] 232 | @defform[(semiquoted-templates [(var-id ...) tpl ...] ...)] 233 | )]{ 234 | 235 | Produces a @tech{template macro} procedure. Each @racket[[(var-id ...) tpl 236 | ...]] clause is analogous to a single @racket[template], 237 | @racket[semitemplate], @racket[quoted-template], or 238 | @racket[semiquoted-template] procedure; applying the 239 | @racket[templates]-generated procedure is the same as applying a procedure 240 | that corresponds to one of the clauses---the first procedure that accepts 241 | the given number of arguments. If no corresponding procedure accepts the 242 | given number of arguments, a syntax error is raised. 243 | 244 | Example: 245 | @example[ 246 | (define-syntax f 247 | (templates [() 0] 248 | [($x) '$x] 249 | [($x $y) '$x-$y])) 250 | (list (f) (f one) (f one two)) 251 | (eval:error (f one two three)) 252 | ] 253 | } 254 | 255 | @deftogether[( 256 | @defform[(untemplate expr)] 257 | @defform[(untemplate-splicing expr)] 258 | )]{ 259 | 260 | Escapes from an expanding template and replaces itself with the result of 261 | @racket[expr], an expression at @rtech{phase level} 1 relative to the 262 | surrounding context. 263 | 264 | Examples: 265 | @example[ 266 | (let-syntax ([x #'(+ 2 3)]) 267 | (begin-template 268 | (+ 1 (untemplate (syntax-local-value #'x))))) 269 | (begin-template 270 | '(1 (untemplate-splicing '(2 3)))) 271 | ] 272 | 273 | If @var[expr] does not evaluate to a @rtech{syntax object}, the result is 274 | wrapped in the @rtech{lexical information}, source-location information, and 275 | @rtech{syntax properties} of @var[expr]. 276 | 277 | Examples: 278 | @example[ 279 | (begin-template #'(untemplate 'here)) 280 | (begin-template #'(untemplate (datum->syntax #f 'nowhere))) 281 | ] 282 | } 283 | 284 | @; ----------------------------------------------------------------------------- 285 | 286 | @section{Combiners} 287 | 288 | @defform[(begin-template tpl ...)]{ 289 | 290 | Equivalent to @racket[(with-template () tpl ...)]. 291 | 292 | Example: 293 | @example[ 294 | (begin-template 1 2 3) 295 | ] 296 | } 297 | 298 | @defform[(begin0-template ([var-id val-expr] ...) tpl ...)]{ 299 | 300 | Like @racket[begin-template], except the result of the first @var[tpl] is 301 | the result of the @racket[begin0-template] form. 302 | 303 | Example: 304 | @example[ 305 | (begin0-template 1 2 3) 306 | ] 307 | } 308 | 309 | @defform[(if-template test-expr then-tpl else-tpl)]{ 310 | 311 | Evaluates @var[test-expr], which is an expression at @rtech{phase level} 1 312 | relative to the surrounding context. If it produces any value other than 313 | @racket[#f], then @var[then-tpl] takes its place. Otherwise, @var[else-tpl] 314 | takes its place. 315 | 316 | Examples: 317 | @example[ 318 | (begin-template 319 | `(if-template (positive? -5) ,(error "doesn't get here") >>)) 320 | (begin-template 321 | `(if-template (positive? 5) << ,(error "doesn't get here"))) 322 | (let-syntax ([x 'we-have-no-bananas]) 323 | (with-template ([$+ yes] 324 | [$- no]) 325 | (if-template (syntax-local-value #'x) "$+" "$-"))) 326 | (let-syntax ([x #f]) 327 | (with-template ([$+ yes] 328 | [$- no]) 329 | (if-template (syntax-local-value #'x) "$+" "$-"))) 330 | ] 331 | } 332 | 333 | @defform[ 334 | #:literals (else) 335 | (cond-template [test-expr tpl ...] ... maybe-else-clause) 336 | #:grammar [(maybe-else-clause (code:line) 337 | [else tpl ...])] 338 | ]{ 339 | 340 | A clause that starts with @racket[else] must be the last clause. 341 | 342 | If no clauses are present, @racket[(void)] takes the place of the 343 | @racket[cond-template] form. 344 | 345 | If the first clause does not start with @racket[else] and its 346 | @var[test-expr], which is an expression at @rtech{phase level} 1 relative to 347 | the surrounding context, produces @racket[#f], then the result is the same 348 | as a @racket[cond-template] form with the remaining clauses. Otherwise, the 349 | @var[tpl]s take the place of the @racket[cond-template] form. 350 | 351 | Examples: 352 | @example[ 353 | (cond-template) 354 | (cond-template [else 5]) 355 | (let-syntax ([x #f] 356 | [y #t]) 357 | (begin-template 358 | `(cond-template 359 | [(positive? -5) ,(error "doesn't get here")] 360 | [(syntax-local-value #'x) ,(error "doesn't get here, either")] 361 | [(syntax-local-value #'y) here]))) 362 | ] 363 | } 364 | 365 | @defform[(when-template test-expr tpl ...)]{ 366 | 367 | Evaluates @var[test-expr], which is an expression at @rtech{phase level} 1 368 | relative to the surrounding context. If the result is not @racket[#f], then 369 | the @var[tpl]s takes the place of the @racket[when-template] form. 370 | Otherwise, @racket[(void)] takes its place. 371 | 372 | Examples: 373 | @example[ 374 | (displayln (when-template #f 'hi)) 375 | (begin-template 376 | (list (when-template #t 'hey 'there))) 377 | ] 378 | } 379 | 380 | @defform[(unless-template test-expr tpl ...)]{ 381 | 382 | Equivalent to @racket[(when-template (not test-expr) tpl ...)]. 383 | 384 | Examples: 385 | @example[ 386 | (displayln (unless-template #f 'hi)) 387 | (begin-template 388 | (list (unless-template #t 'hey 'there))) 389 | ] 390 | } 391 | 392 | @defform[(for/template ([var-id seq-expr] ...) tpl ...)]{ 393 | 394 | Iterates like @racket[for/list], but results are accumulated into a 395 | @racket[begin-template] instead of a list. 396 | 397 | Example: 398 | @example[ 399 | (for/template ([$x (in-syntax #'(A B C))] 400 | [$n (in-naturals)]) 401 | (define $x (add1 $n))) 402 | (list A B C) 403 | ] 404 | 405 | When @racket[for/template] is used in an @rtech{expression context} inside a 406 | template, the results are spliced into the enclosing context. 407 | 408 | Example: 409 | @example[ 410 | (begin-template 411 | (list (for/template ([$n (in-range 10)]) $n))) 412 | ] 413 | 414 | When used outside any other template, the results are wrapped with 415 | @racket[begin]. 416 | 417 | Example: 418 | @example[ 419 | (list (for/template ([$n 10]) (add1 $n))) 420 | ] 421 | } 422 | 423 | @defform[(for*/template ([var-id seq-expr] ...) tpl ...)]{ 424 | 425 | Like @racket[for/template], but with all of its sequence iterations nested. 426 | 427 | Examples: 428 | @example[ 429 | (begin-template 430 | (list (for*/template ([$m (in-range 3)] 431 | [$n (in-range 3)]) 432 | (+ $n (* $m 3))))) 433 | ] 434 | } 435 | 436 | 437 | @; ----------------------------------------------------------------------------- 438 | 439 | @section{Binding Forms} 440 | 441 | @defform[(define-template (id var-id ...) tpl ...)]{ 442 | 443 | Creates a @rtech{transformer} binding of @var[id] to @racket[(template 444 | (var-id ...) tpl ...)]. 445 | 446 | Example: 447 | @example[ 448 | (define-template (iterate-with $for) 449 | ($for/list ([x (in-range 3)] 450 | [y (in-range 3)]) 451 | (+ y (* 3 x)))) 452 | (iterate-with for) 453 | (iterate-with for*) 454 | ] 455 | } 456 | 457 | @defform[(define-templates [(id var-id ...) tpl ...] ...)]{ 458 | 459 | Like @racket[define-template], but creates a @rtech{transformer} binding for 460 | each @var[id]. 461 | 462 | Example: 463 | @example[ 464 | (define-templates 465 | [(show $obj) (displayln "$obj")] 466 | [(many $objs) (for/template ([$obj '$objs]) (show $obj))]) 467 | (many (one two three)) 468 | ] 469 | } 470 | 471 | @defform[(let-template ([(id var-id ...) tpl ...] ...) body-tpl ...)]{ 472 | 473 | Creates a @rtech{transformer} binding of each @var[id] with 474 | @racket[(template (var-id ...) tpl ...)]. Each @var[id] is bound in the 475 | @var[body-tpl]s, and not in other @var[tpl]s. 476 | 477 | Example: 478 | @example[ 479 | (let-template ([(fwd $x $y) $x$y] 480 | [(rev $x $y) $y$x]) 481 | '((fwd a b) (rev a b))) 482 | ] 483 | } 484 | 485 | @defform[(letrec-template ([(id var-id ...) tpl ...] ...) body-tpl ...)]{ 486 | 487 | Like @racket[let-template], except that each @var[var-id] is also bound 488 | within all @var[tpl]s. 489 | 490 | Example: 491 | @EXAMPLE[ 492 | (letrec-template 493 | ([(E? $n) (if-template (zero? $n) #t (O? #,(sub1 $n)))] 494 | [(O? $n) #,(not (E? $n))]) 495 | '((E? 10) (E? 11))) 496 | ] 497 | } 498 | 499 | @deftogether[( 500 | @defform[(splicing-let-template ([(id var-id ...) tpl ...] ...) body-tpl ...)] 501 | @defform[(splicing-letrec-template ([(id var-id ...) tpl ...] ...) body-tpl ...)] 502 | )]{ 503 | 504 | Like @racket[let-template] and @racket[letrec-template], except that in a 505 | definition context, the @var[body-tpl]s are spliced into the enclosing 506 | definition context (in the same way as for @racket[with-template]). 507 | 508 | Examples: 509 | @example[ 510 | (splicing-let-template ([(one) 1]) 511 | (define o (one))) 512 | o 513 | (eval:error (one)) 514 | ] 515 | 516 | @EXAMPLE[ 517 | (splicing-letrec-template 518 | ([(E? $n) (if-template (zero? $n) #t (O? #,(sub1 $n)))] 519 | [(O? $n) #,(not (E? $n))]) 520 | (define is-11-even? (E? 11)) 521 | (define is-10-even? (E? 10))) 522 | (list is-11-even? is-10-even?) 523 | ] 524 | } 525 | 526 | @; ----------------------------------------------------------------------------- 527 | 528 | @section{Module Templates} 529 | 530 | In @racketcommentfont{template/tests/lang-template.rkt}: 531 | 532 | @(begin-for-syntax (define-runtime-path lang-tpl-path "lang-template.rkt")) 533 | @(let-syntax ([go (λ _ 534 | (syntax-local-eval 535 | #`#'(codeblock 536 | #,@(let loop ([lines (file->lines lang-tpl-path)]) 537 | (if (string=? (car lines) "") 538 | (map (curryr string-append "\n") (cdr lines)) 539 | (loop (cdr lines)))))))]) 540 | (go)) 541 | 542 | @defform[(load-template mod-path id)]{ 543 | 544 | Binds @var[id] to the @tech{template macro} provided by @var[mod-path]. 545 | 546 | Example: 547 | @example[ 548 | (load-template template/scribblings/lang-template tpl) 549 | (tpl a 4) 550 | as 551 | a4 552 | ] 553 | } 554 | 555 | @defform[(template-module-begin (var-id ...) tpl ...)]{ 556 | 557 | Exports a binding of @var[the-template] to @racket[(template (var-id ...) 558 | tpl ...)]. 559 | 560 | Example: 561 | @example[ 562 | (module my-template-mod template/lang 563 | ($x) 564 | (define $xs '($x $x $x $x))) 565 | (require 'my-template-mod) 566 | (the-template b) 567 | bs 568 | ] 569 | } 570 | 571 | @; ----------------------------------------------------------------------------- 572 | 573 | @section{Developer Tools} 574 | 575 | @defform[(debug-template tpl)]{ 576 | 577 | Displays the expanded form of @var[tpl], then evaluates the result. 578 | 579 | Examples: 580 | @example[ 581 | (debug-template (for/template ([$n 10]) $n)) 582 | ] 583 | 584 | @example[ 585 | (debug-template (begin-template (list (for/template ([$n 10]) $n)))) 586 | ] 587 | } 588 | 589 | @defform[(debug-template/scopes tpl)]{ 590 | 591 | Displays the expanded form of @var[tpl], annotated with superscripts 592 | indicating the scopes present on them, then evaluates the result. 593 | 594 | Example: 595 | @example[ 596 | (debug-template/scopes 597 | (for/template ([$x (in-syntax #'(A B C D E))] 598 | [$n (in-range 1 6)]) 599 | #'$x$n)) 600 | ] 601 | } 602 | 603 | @defform[(reset-debug-scopes)]{ 604 | 605 | Resets the internal counter used by @racket[debug-template/scopes] to print 606 | a summary table. 607 | 608 | } 609 | 610 | @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 611 | 612 | @require[scribble/example] 613 | 614 | @close-eval[template-evaluator] 615 | -------------------------------------------------------------------------------- /tests/binding-forms.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (require template) 18 | 19 | (module+ test 20 | (require rackunit rackunit/text-ui syntax/macro-testing 21 | (for-syntax racket/base)) 22 | 23 | (define (run-all-tests) 24 | (run-tests binding-forms) 25 | (void)) 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | (define-test-suite binding-forms 30 | (test-case "templates" 31 | (define-syntax tpl (templates [() 0] [($x) $x0] [($x $y) $x00$y00])) 32 | (check = (tpl) 0) 33 | (check = (tpl 1) 10) 34 | (check = (tpl 1 2) 100200)) 35 | 36 | (test-case "template" 37 | (define-syntax tpl (template ($x $y) '($x$y $y$x $xy $yx))) 38 | (check equal? (tpl a b) '(ab ba ay bx))) 39 | 40 | (test-case "define-template" 41 | (define-template (tpl $x) (define $xs '($x $x $x $x))) 42 | (tpl a) 43 | (check equal? as '(a a a a))) 44 | 45 | (test-case "define-template recursive" 46 | (define-template (power $b $p) 47 | (if-template (zero? $p) 1 (* $b (power $b (untemplate (sub1 $p)))))) 48 | (define-template (power* $b $p) 49 | (if-template (zero? $p) 1 `(* $b ,(power* $b (untemplate (sub1 $p)))))) 50 | (check = (power 2 3) 8) 51 | (check equal? (power* 2 3) '(* 2 (* 2 (* 2 1)))) 52 | (check-exn #rx"illegal outside of template macro$" 53 | (λ () (convert-syntax-error (untemplate 123))))) 54 | 55 | (test-case "let-template" 56 | (check equal? (let-template ([(foo $x $y) '($x$y $y$x)] 57 | [(bar $x $y) '($xy $yx )]) 58 | (append (foo a b) (bar c d))) 59 | '(ab ba cy dx))) 60 | 61 | (test-case "letrec-template" 62 | (check-exn #rx"evn: unbound identifier" 63 | (λ () 64 | (convert-compile-time-error 65 | (let-template ([(evn $b) #t] 66 | [(odd $b) (not (evn $b))]) 67 | (odd 123))))) 68 | (letrec-template 69 | ([(is-even? $n) (if-template (zero? $n) #t (is-odd? (untemplate (sub1 $n))))] 70 | [(is-odd? $n) (not (is-even? $n))]) 71 | (check-false (is-even? 11)) 72 | (check-true (is-even? 10)))) 73 | 74 | (test-case "splicing-let-template" 75 | (splicing-let-template ([(tpl $x) (define $xs '($x $x $x $x $x))]) 76 | (tpl a)) 77 | (check equal? as '(a a a a a))) 78 | 79 | (test-case "splicing-letrec-template" 80 | (splicing-letrec-template 81 | ([(is-even? $n) (if-template (zero? $n) #t (is-odd? (untemplate (sub1 $n))))] 82 | [(is-odd? $n) (not (is-even? $n))]) 83 | (define is-11-even? (is-even? 11)) 84 | (define is-10-even? (is-even? 10))) 85 | (check-false is-11-even?) 86 | (check-true is-10-even?)) 87 | 88 | (test-suite "combiners" 89 | (test-case "if-template" 90 | (define-template (tpl $b) (if-template $b $b 0)) 91 | (check-true (tpl #t)) 92 | (check = (tpl #f) 0)) 93 | 94 | (test-case "cond-template" 95 | (define-template (tpl $a) 96 | (cond-template [( number? $a) 'N] 97 | [(boolean? $a) 'B] 98 | [( string? $a) 'S] 99 | [ else '?])) 100 | (check eq? (tpl 123) 'N) 101 | (check eq? (tpl "\"x\"") 'S) 102 | (check eq? (tpl #f) 'B) 103 | (check eq? (tpl '()) '?)) 104 | 105 | (test-case "when-template" 106 | (define-template (tpl $b) 0 (when-template $b 1)) 107 | (check = (tpl #f) 0) 108 | (check = (tpl #t) 1)) 109 | 110 | (test-case "unless-template" 111 | (define-template (tpl $b) 0 (unless-template $b 1)) 112 | (check = (tpl #t) 0) 113 | (check = (tpl #f) 1)))) 114 | 115 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 116 | 117 | (run-all-tests)) 118 | -------------------------------------------------------------------------------- /tests/combiners.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (require template) 18 | 19 | (module+ test 20 | (require rackunit rackunit/text-ui 21 | (for-syntax racket/base racket/sequence)) 22 | 23 | (define (run-all-tests) 24 | (run-tests combiners) 25 | (void)) 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | (define-test-suite combiners 30 | (test-suite "begin-template" 31 | (test-case "as form" (begin-template (define x 123)) (check = x 123)) 32 | (test-case "as expression" (check = (begin-template 123 456) 456)) 33 | (test-case "inside with-template" 34 | (check equal? (begin-template `((with-template ([$x 1]) $x #,(+ $x 1) #,(+ $x 2)))) 35 | '(1 2 3)) 36 | (check equal? (begin-template '((with-template ([$x 1]) $x #,(+ $x 1) #,(+ $x 2)))) 37 | '(1 2 3)) 38 | (check equal? (begin-template '((with-template ([$x 1]) $x #,(+ $x 1) #,(+ $x 2)))) 39 | '(1 2 3)))) 40 | 41 | (test-case "begin0-template" 42 | (check = (begin0-template 123 456) 123)) 43 | 44 | (test-case "if-template" 45 | (check equal? (begin-template '((with-template ([$x 1] [$y 0]) 46 | (if-template #t $x $y) 47 | (if-template #f $x $y)))) 48 | '(1 0))) 49 | 50 | (test-case "cond-template" 51 | (check = (cond-template [#t 0] [#f 1] [else -1]) 0) 52 | (check = (cond-template [#f 0] [#t 1] [else -1]) 1) 53 | (check = (cond-template [#f 0] [#f 1] [else -1]) -1)) 54 | 55 | (test-case "when-template" 56 | (check-pred void? (when-template #f 1)) 57 | (check-pred void? (with-template ([$b #f]) (when-template $b 1))) 58 | (check = (when-template #t 1) 1) 59 | (check = (with-template ([$b #t]) (when-template $b 1)) 1)) 60 | 61 | (test-case "unless-template" 62 | (check-pred void? (unless-template #t 1)) 63 | (check-pred void? (with-template ([$b #t]) (unless-template $b 1))) 64 | (check = (unless-template #f 1) 1) 65 | (check = (with-template ([$b #f]) (unless-template $b 1)) 1)) 66 | 67 | (test-case "for/template" 68 | (for/template ([$x (in-syntax #'(A B C))] 69 | [$a (in-naturals)]) 70 | (define $x $a0)) 71 | (check = A 0) 72 | (check = B 10) 73 | (check = C 20) 74 | (check equal? (begin-template (list (for/template ([$m (in-range 3)] 75 | [$n (in-range 3)]) 76 | (+ $n (* $m 3))))) 77 | '(0 4 8))) 78 | 79 | (test-case "for*/template" 80 | (for*/template ([$x (in-syntax #'(A B C))] 81 | [$y (in-range 3)]) 82 | (define $x$y (add1 $y))) 83 | (check equal? (list A0 A1 A2 B0 B1 B2 C0 C1 C2) '(1 2 3 1 2 3 1 2 3)) 84 | (check equal? (begin-template (list (for*/template ([$m (in-range 3)] 85 | [$n (in-range 3)]) 86 | (+ $n (* $m 3))))) 87 | '(0 1 2 3 4 5 6 7 8)))) 88 | 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | 91 | (run-all-tests)) 92 | -------------------------------------------------------------------------------- /tests/literals.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (require template) 18 | 19 | (module+ test 20 | (require rackunit rackunit/text-ui) 21 | 22 | (provide (rename-out [literals the-tests])) 23 | 24 | (define (run-all-tests) 25 | (run-tests literals) 26 | (void)) 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | 30 | (define-test-suite literals 31 | (test-suite "boolean" 32 | (test-suite "with-template" 33 | (test-case "datum" 34 | (check equal? (with-template () #t) #t) 35 | (check equal? (with-template () #f) #f) 36 | (check equal? (with-template ([$b #t]) #f) #f) 37 | (check equal? (with-template ([$b #t]) $b) #t)) 38 | (test-case "quasisyntax" 39 | (check equal? (syntax-e (with-template () #`#t)) #t) 40 | (check equal? (syntax-e (with-template () #`#f)) #f) 41 | (check equal? (syntax-e (with-template ([$b #t]) #`#f)) #f) 42 | (check equal? (syntax-e (with-template ([$b #t]) #`$b)) #t)) 43 | (test-case "syntax" 44 | (check equal? (syntax-e (with-template () #'#t)) #t) 45 | (check equal? (syntax-e (with-template () #'#f)) #f) 46 | (check equal? (syntax-e (with-template ([$b #t]) #'#f)) #f) 47 | (check equal? (syntax-e (with-template ([$b #t]) #'$b)) #t))) 48 | (test-suite "quote-template" 49 | (test-case "datum" 50 | (check equal? (quote-template () #t) #t) 51 | (check equal? (quote-template () #f) #f) 52 | (check equal? (quote-template ([$b #t]) #f) #f) 53 | (check equal? (quote-template ([$b #t]) $b) #t)) 54 | (test-case "quasisyntax" 55 | (check equal? (syntax-e (quote-template () #`#t)) #t) 56 | (check equal? (syntax-e (quote-template () #`#f)) #f) 57 | (check equal? (syntax-e (quote-template ([$b #t]) #`#f)) #f) 58 | (check equal? (syntax-e (quote-template ([$b #t]) #`$b)) #t)) 59 | (test-case "syntax" 60 | (check equal? (syntax-e (quote-template () #'#t)) #t) 61 | (check equal? (syntax-e (quote-template () #'#f)) #f) 62 | (check equal? (syntax-e (quote-template ([$b #t]) #'#f)) #f) 63 | (check equal? (syntax-e (quote-template ([$b #t]) #'$b)) #t)))) 64 | 65 | (test-suite "number" 66 | (test-suite "with-template" 67 | (test-case "datum" 68 | (check = (with-template () 0) 0) 69 | (check = (with-template ([$n 1]) 2) 2) 70 | (check = (with-template ([$n 1]) $n) 1) 71 | (check = (with-template ([$n 1] [$m 2]) $n$m3) 123)) 72 | (test-case "quasisyntax" 73 | (check = (syntax-e (with-template () #`0)) 0) 74 | (check = (syntax-e (with-template ([$n 1]) #`2)) 2) 75 | (check = (syntax-e (with-template ([$n 1]) #`$n)) 1) 76 | (check = (syntax-e (with-template ([$n 1] [$m 2]) #`$n$m3)) 123)) 77 | (test-case "syntax" 78 | (check = (syntax-e (with-template () #'0)) 0) 79 | (check = (syntax-e (with-template ([$n 1]) #'2)) 2) 80 | (check = (syntax-e (with-template ([$n 1]) #'$n)) 1) 81 | (check = (syntax-e (with-template ([$n 1] [$m 2]) #'$n$m3)) 123))) 82 | (test-suite "quote-template" 83 | (test-case "datum" 84 | (check = (quote-template () 0) 0) 85 | (check = (quote-template ([$n 1]) 2) 2) 86 | (check = (quote-template ([$n 1]) $n) 1) 87 | (check = (quote-template ([$n 1] [$m 2]) $n$m3) 123) 88 | (check = (quote-template ([$n 1] [$m 2]) (add1 $n$m$m)) 123)) 89 | (test-case "quasisyntax" 90 | (check = (syntax-e (quote-template () #`0)) 0) 91 | (check = (syntax-e (quote-template ([$n 1]) #`2)) 2) 92 | (check = (syntax-e (quote-template ([$n 1]) #`$n)) 1) 93 | (check = (syntax-e (quote-template ([$n 1] [$m 2]) #`$n$m3)) 123)) 94 | (test-case "syntax" 95 | (check = (syntax-e (quote-template () #'0)) 0) 96 | (check = (syntax-e (quote-template ([$n 1]) #'2)) 2) 97 | (check = (syntax-e (quote-template ([$n 1]) #'$n)) 1) 98 | (check = (syntax-e (quote-template ([$n 1] [$m 2]) #'$n$m3)) 123)))) 99 | 100 | (test-suite "string" 101 | (test-suite "with-template" 102 | (test-case "datum" 103 | (check string=? (with-template () "") "") 104 | (check string=? (with-template ([$n 1]) "2") "2") 105 | (check string=? (with-template ([$n 1]) "$n") "1") 106 | (check string=? (with-template ([$n 1] [$m 2]) "$n$m3") "123")) 107 | (test-case "quasisyntax" 108 | (check string=? (syntax-e (with-template () #`"0")) "0") 109 | (check string=? (syntax-e (with-template ([$n 1]) #`"2")) "2") 110 | (check string=? (syntax-e (with-template ([$n 1]) #`"$n")) "1") 111 | (check string=? (syntax-e (with-template ([$n 1] [$m 2]) #`"$n$m3")) "123")) 112 | (test-case "syntax" 113 | (check string=? (syntax-e (with-template () #'"0")) "0") 114 | (check string=? (syntax-e (with-template ([$n 1]) #'"2")) "2") 115 | (check string=? (syntax-e (with-template ([$n 1]) #'"$n")) "1") 116 | (check string=? (syntax-e (with-template ([$n 1] [$m 2]) #'"$n$m3")) "123"))) 117 | (test-suite "quote-template" 118 | (test-case "datum" 119 | (check string=? (quote-template () "") "") 120 | (check string=? (quote-template ([$n 1]) "2") "2") 121 | (check string=? (quote-template ([$n 1]) "$n") "1") 122 | (check string=? (quote-template ([$n 1] [$m 2]) "$n$m3") "123")) 123 | (test-case "quasisyntax" 124 | (check string=? (syntax-e (quote-template () #`"0")) "0") 125 | (check string=? (syntax-e (quote-template ([$n 1]) #`"2")) "2") 126 | (check string=? (syntax-e (quote-template ([$n 1]) #`"$n")) "1") 127 | (check string=? (syntax-e (quote-template ([$n 1] [$m 2]) #`"$n$m3")) "123")) 128 | (test-case "syntax" 129 | (check string=? (syntax-e (quote-template () #'"0")) "0") 130 | (check string=? (syntax-e (quote-template ([$n 1]) #'"2")) "2") 131 | (check string=? (syntax-e (quote-template ([$n 1]) #'"$n")) "1") 132 | (check string=? (syntax-e (quote-template ([$n 1] [$m 2]) #'"$n$m3")) "123")))) 133 | 134 | (test-suite "byte string" 135 | (test-suite "with-template" 136 | (test-case "datum" 137 | (check bytes=? (with-template () #"") #"") 138 | (check bytes=? (with-template ([$n 1]) #"2") #"2") 139 | (check bytes=? (with-template ([$n 1]) #"$n") #"1") 140 | (check bytes=? (with-template ([$n 1] [$m 2]) #"$n$m3") #"123")) 141 | (test-case "quasisyntax" 142 | (check bytes=? (syntax-e (with-template () #`#"0")) #"0") 143 | (check bytes=? (syntax-e (with-template ([$n 1]) #`#"2")) #"2") 144 | (check bytes=? (syntax-e (with-template ([$n 1]) #`#"$n")) #"1") 145 | (check bytes=? (syntax-e (with-template ([$n 1] [$m 2]) #`#"$n$m3")) #"123")) 146 | (test-case "syntax" 147 | (check bytes=? (syntax-e (with-template () #'#"0")) #"0") 148 | (check bytes=? (syntax-e (with-template ([$n 1]) #'#"2")) #"2") 149 | (check bytes=? (syntax-e (with-template ([$n 1]) #'#"$n")) #"1") 150 | (check bytes=? (syntax-e (with-template ([$n 1] [$m 2]) #'#"$n$m3")) #"123"))) 151 | (test-suite "quote-template" 152 | (test-case "datum" 153 | (check bytes=? (quote-template () #"") #"") 154 | (check bytes=? (quote-template ([$n 1]) #"2") #"2") 155 | (check bytes=? (quote-template ([$n 1]) #"$n") #"1") 156 | (check bytes=? (quote-template ([$n 1] [$m 2]) #"$n$m3") #"123")) 157 | (test-case "quasisyntax" 158 | (check bytes=? (syntax-e (quote-template () #`#"0")) #"0") 159 | (check bytes=? (syntax-e (quote-template ([$n 1]) #`#"2")) #"2") 160 | (check bytes=? (syntax-e (quote-template ([$n 1]) #`#"$n")) #"1") 161 | (check bytes=? (syntax-e (quote-template ([$n 1] [$m 2]) #`#"$n$m3")) 162 | #"123")) 163 | (test-case "syntax" 164 | (check bytes=? (syntax-e (quote-template () #'#"0")) #"0") 165 | (check bytes=? (syntax-e (quote-template ([$n 1]) #'#"2")) #"2") 166 | (check bytes=? (syntax-e (quote-template ([$n 1]) #'#"$n")) #"1") 167 | (check bytes=? (syntax-e (quote-template ([$n 1] [$m 2]) #'#"$n$m3")) 168 | #"123")))) 169 | 170 | (test-suite "symbol" 171 | (test-suite "with-template" 172 | (test-case "datum" 173 | (check eq? (with-template () 'X) 'X) 174 | (check eq? (with-template ([$x a]) 'b) 'b) 175 | (check eq? (with-template ([$x a]) '$x) 'a) 176 | (check eq? (with-template ([$x a] [$y b]) '$x$yc) 'abc)) 177 | (test-case "quasisyntax" 178 | (check eq? (syntax-e (with-template () #`X)) 'X) 179 | (check eq? (syntax-e (with-template ([$x a]) #`b)) 'b) 180 | (check eq? (syntax-e (with-template ([$x a]) #`a)) 'a) 181 | (check eq? (syntax-e (with-template ([$x a] [$y b]) #`$x$yc)) 'abc)) 182 | (test-case "syntax" 183 | (check eq? (syntax-e (with-template () #'X)) 'X) 184 | (check eq? (syntax-e (with-template ([$x a]) #'b)) 'b) 185 | (check eq? (syntax-e (with-template ([$x a]) #'$x)) 'a) 186 | (check eq? (syntax-e (with-template ([$x a] [$y b]) #'$x$yc)) 'abc))) 187 | (test-suite "quote-template" 188 | (test-case "datum" 189 | (check eq? (quote-template () 'X) 'X) 190 | (check eq? (quote-template ([$x a]) 'b) 'b) 191 | (check eq? (quote-template ([$x a]) '$x) 'a) 192 | (check eq? (quote-template ([$x a] [$y b]) '$x$yc) 'abc)) 193 | (test-case "quasisyntax" 194 | (check eq? (syntax-e (quote-template () #`X)) 'X) 195 | (check eq? (syntax-e (quote-template ([$x a]) #`b)) 'b) 196 | (check eq? (syntax-e (quote-template ([$x a]) #`$x)) 'a) 197 | (check eq? (syntax-e (quote-template ([$x a] [$y b]) #`$x$yc)) 'abc)) 198 | (test-case "syntax" 199 | (check eq? (syntax-e (quote-template () #'X)) 'X) 200 | (check eq? (syntax-e (quote-template ([$x a]) #'b)) 'b) 201 | (check eq? (syntax-e (quote-template ([$x a]) #'$x)) 'a) 202 | (check eq? (syntax-e (quote-template ([$x a] [$y b]) #'$x$yc)) 'abc)))) 203 | 204 | (test-suite "regexp" 205 | (test-suite "with-template" 206 | (test-case "datum" 207 | (check equal? (with-template () #rx"X") #rx"X") 208 | (check equal? (with-template ([$x A]) #rx"B") #rx"B") 209 | (check equal? (with-template ([$x A]) #rx"$x") #rx"A") 210 | (check equal? (with-template ([$x A] [$y B]) #rx"$x$yC") #rx"ABC")) 211 | (test-case "quasisyntax" 212 | (check equal? (syntax-e (with-template () #`#rx"X")) #rx"X") 213 | (check equal? (syntax-e (with-template ([$x A]) #`#rx"B")) #rx"B") 214 | (check equal? (syntax-e (with-template ([$x A]) #`#rx"$x")) #rx"A") 215 | (check equal? (syntax-e (with-template ([$x A] [$y B]) #`#rx"$x$yC")) 216 | #rx"ABC")) 217 | (test-case "syntax" 218 | (check equal? (syntax-e (with-template () #'#rx"X")) #rx"X") 219 | (check equal? (syntax-e (with-template ([$x A]) #'#rx"B")) #rx"B") 220 | (check equal? (syntax-e (with-template ([$x A]) #'#rx"$x")) #rx"A") 221 | (check equal? (syntax-e (with-template ([$x A] [$y B]) #'#rx"$x$yC")) 222 | #rx"ABC"))) 223 | (test-suite "quote-template" 224 | (test-case "datum" 225 | (check equal? (quote-template () #rx"X") #rx"X") 226 | (check equal? (quote-template ([$x A]) #rx"B") #rx"B") 227 | (check equal? (quote-template ([$x A]) #rx"$x") #rx"A") 228 | (check equal? (quote-template ([$x A] [$y B]) #rx"$x$yC") #rx"ABC")) 229 | (test-case "quasisyntax" 230 | (check equal? (syntax-e (quote-template () #`#rx"X")) #rx"X") 231 | (check equal? (syntax-e (quote-template ([$x A]) #`#rx"B")) #rx"B") 232 | (check equal? (syntax-e (quote-template ([$x A]) #`#rx"$x")) #rx"A") 233 | (check equal? (syntax-e (quote-template ([$x A] [$y B]) #`#rx"$x$yC")) 234 | #rx"ABC")) 235 | (test-case "syntax" 236 | (check equal? (syntax-e (quote-template () #'#rx"X")) #rx"X") 237 | (check equal? (syntax-e (quote-template ([$x A]) #'#rx"B")) #rx"B") 238 | (check equal? (syntax-e (quote-template ([$x A]) #'#rx"$x")) #rx"A") 239 | (check equal? (syntax-e (quote-template ([$x A] [$y B]) #'#rx"$x$yC")) 240 | #rx"ABC")))) 241 | 242 | (test-suite "pregexp" 243 | (test-suite "with-template" 244 | (test-case "datum" 245 | (check equal? (with-template () #px"X") #px"X") 246 | (check equal? (with-template ([$x A]) #px"B") #px"B") 247 | (check equal? (with-template ([$x A]) #px"$x") #px"A") 248 | (check equal? (with-template ([$x A] [$y B]) #px"$x$yC") #px"ABC")) 249 | (test-case "quasisyntax" 250 | (check equal? (syntax-e (with-template () #`#px"X")) #px"X") 251 | (check equal? (syntax-e (with-template ([$x A]) #`#px"B")) #px"B") 252 | (check equal? (syntax-e (with-template ([$x A]) #`#px"$x")) #px"A") 253 | (check equal? (syntax-e (with-template ([$x A] [$y B]) #`#px"$x$yC")) 254 | #px"ABC")) 255 | (test-case "syntax" 256 | (check equal? (syntax-e (with-template () #'#px"X")) #px"X") 257 | (check equal? (syntax-e (with-template ([$x A]) #'#px"B")) #px"B") 258 | (check equal? (syntax-e (with-template ([$x A]) #'#px"$x")) #px"A") 259 | (check equal? (syntax-e (with-template ([$x A] [$y B]) #'#px"$x$yC")) 260 | #px"ABC"))) 261 | (test-suite "quote-template" 262 | (test-case "datum" 263 | (check equal? (quote-template () #px"X") #px"X") 264 | (check equal? (quote-template ([$x A]) #px"B") #px"B") 265 | (check equal? (quote-template ([$x A]) #px"$x") #px"A") 266 | (check equal? (quote-template ([$x A] [$y B]) #px"$x$yC") #px"ABC")) 267 | (test-case "quasisyntax" 268 | (check equal? (syntax-e (quote-template () #`#px"X")) #px"X") 269 | (check equal? (syntax-e (quote-template ([$x A]) #`#px"B")) #px"B") 270 | (check equal? (syntax-e (quote-template ([$x A]) #`#px"$x")) #px"A") 271 | (check equal? (syntax-e (quote-template ([$x A] [$y B]) #`#px"$x$yC")) 272 | #px"ABC")) 273 | (test-case "syntax" 274 | (check equal? (syntax-e (quote-template () #'#px"X")) #px"X") 275 | (check equal? (syntax-e (quote-template ([$x A]) #'#px"B")) #px"B") 276 | (check equal? (syntax-e (quote-template ([$x A]) #'#px"$x")) #px"A") 277 | (check equal? (syntax-e (quote-template ([$x A] [$y B]) #'#px"$x$yC")) 278 | #px"ABC")))) 279 | 280 | (test-suite "keyword" 281 | (test-suite "with-template" 282 | (test-case "datum" 283 | (check eq? (with-template () '#:X) '#:X) 284 | (check eq? (with-template ([$x I]) 'J) 'J) 285 | (check eq? (with-template ([$x I]) '$x) 'I) 286 | (check eq? (with-template ([$x I] [$y J]) '$x$yK) 'IJK)) 287 | (test-case "quasisyntax" 288 | (check eq? (syntax-e (with-template () #`X)) 'X) 289 | (check eq? (syntax-e (with-template ([$x I]) #`J)) 'J) 290 | (check eq? (syntax-e (with-template ([$x I]) #`I)) 'I) 291 | (check eq? (syntax-e (with-template ([$x I] [$y J]) #`$x$yK)) 'IJK)) 292 | (test-case "syntax" 293 | (check eq? (syntax-e (with-template () #'X)) 'X) 294 | (check eq? (syntax-e (with-template ([$x I]) #'J)) 'J) 295 | (check eq? (syntax-e (with-template ([$x I]) #'$x)) 'I) 296 | (check eq? (syntax-e (with-template ([$x I] [$y J]) #'$x$yK)) 'IJK))) 297 | (test-suite "quote-template" 298 | (test-case "datum" 299 | (check eq? (quote-template () 'X) 'X) 300 | (check eq? (quote-template ([$x I]) 'J) 'J) 301 | (check eq? (quote-template ([$x I]) '$x) 'I) 302 | (check eq? (quote-template ([$x I] [$y J]) '$x$yK) 'IJK)) 303 | (test-case "quasisyntax" 304 | (check eq? (syntax-e (quote-template () #`X)) 'X) 305 | (check eq? (syntax-e (quote-template ([$x I]) #`J)) 'J) 306 | (check eq? (syntax-e (quote-template ([$x I]) #`$x)) 'I) 307 | (check eq? (syntax-e (quote-template ([$x I] [$y J]) #`$x$yK)) 'IJK)) 308 | (test-case "syntax" 309 | (check eq? (syntax-e (quote-template () #'X)) 'X) 310 | (check eq? (syntax-e (quote-template ([$x I]) #'J)) 'J) 311 | (check eq? (syntax-e (quote-template ([$x I]) #'$x)) 'I) 312 | (check eq? (syntax-e (quote-template ([$x I] [$y J]) #'$x$yK)) 'IJK)))) 313 | 314 | (test-suite "vector" 315 | (test-suite "with-template" 316 | (test-case "datum" 317 | (check equal? (with-template () #(X)) #(X)) 318 | (check equal? (with-template ([$v R]) #(S)) #(S)) 319 | (check equal? (with-template ([$v R]) #($v)) #(R)) 320 | (check equal? (with-template ([$v R] [$u S]) #($v $u T)) #(R S T))) 321 | (test-case "quasisyntax" 322 | (check equal? (syntax->datum (with-template () #`#(X))) #(X)) 323 | (check equal? (syntax->datum (with-template ([$v R]) #`#(S))) #(S)) 324 | (check equal? (syntax->datum (with-template ([$v R]) #`#(R))) #(R)) 325 | (check equal? (syntax->datum (with-template ([$v R] [$u S]) #`#($v $u T))) 326 | #(R S T))) 327 | (test-case "syntax" 328 | (check equal? (syntax->datum (with-template () #'#(X))) #(X)) 329 | (check equal? (syntax->datum (with-template ([$v R]) #'#(S))) #(S)) 330 | (check equal? (syntax->datum (with-template ([$v R]) #'#($v))) #(R)) 331 | (check equal? (syntax->datum (with-template ([$v R] [$u S]) #'#($v $u T))) 332 | #(R S T)))) 333 | (test-suite "quote-template" 334 | (test-case "datum" 335 | (check equal? (quote-template () #(X)) #(X)) 336 | (check equal? (quote-template ([$v R]) #(S)) #(S)) 337 | (check equal? (quote-template ([$v R]) #($v)) #(R)) 338 | (check equal? (quote-template ([$v R] [$u S]) #($v $u T)) #(R S T))) 339 | (test-case "quasisyntax" 340 | (check equal? (syntax->datum (quote-template () #`#(X))) #(X)) 341 | (check equal? (syntax->datum (quote-template ([$v R]) #`#(S))) #(S)) 342 | (check equal? (syntax->datum (quote-template ([$v R]) #`#(R))) #(R)) 343 | (check equal? (syntax->datum (quote-template ([$v R] [$u S]) #`#($v $u T))) 344 | #(R S T))) 345 | (test-case "syntax" 346 | (check equal? (syntax->datum (quote-template () #'#(X))) #(X)) 347 | (check equal? (syntax->datum (quote-template ([$v R]) #'#(S))) #(S)) 348 | (check equal? (syntax->datum (quote-template ([$v R]) #'#($v))) #(R)) 349 | (check equal? (syntax->datum (quote-template ([$v R] [$u S]) #'#($v $u T))) 350 | #(R S T))))) 351 | 352 | (test-suite "box" 353 | (test-suite "with-template" 354 | (test-case "datum" 355 | (check equal? (with-template () #&X) #&X) 356 | (check equal? (with-template ([$v R]) #&S) #&S) 357 | (check equal? (with-template ([$v R]) #&$v) #&R) 358 | (check equal? (with-template ([$v R] [$u S]) #&$v$uT) #&RST)) 359 | (test-case "quasisyntax" 360 | (check equal? (syntax->datum (with-template () #`#&X)) #&X) 361 | (check equal? (syntax->datum (with-template ([$v R]) #`#&S)) #&S) 362 | (check equal? (syntax->datum (with-template ([$v R]) #`#&R)) #&R) 363 | (check equal? (syntax->datum (with-template ([$v R] [$u S]) #`#&$v$uT)) 364 | #&RST)) 365 | (test-case "syntax" 366 | (check equal? (syntax->datum (with-template () #'#&X)) #&X) 367 | (check equal? (syntax->datum (with-template ([$v R]) #'#&S)) #&S) 368 | (check equal? (syntax->datum (with-template ([$v R]) #'#&$v)) #&R) 369 | (check equal? (syntax->datum (with-template ([$v R] [$u S]) #'#&$v$uT)) 370 | #&RST))) 371 | (test-suite "quote-template" 372 | (test-case "datum" 373 | (check equal? (quote-template () #&X) #&X) 374 | (check equal? (quote-template ([$v R]) #&S) #&S) 375 | (check equal? (quote-template ([$v R]) #&$v) #&R) 376 | (check equal? (quote-template ([$v R] [$u S]) #&$v$uT) #&RST)) 377 | (test-case "quasisyntax" 378 | (check equal? (syntax->datum (quote-template () #`#&X)) #&X) 379 | (check equal? (syntax->datum (quote-template ([$v R]) #`#&S)) #&S) 380 | (check equal? (syntax->datum (quote-template ([$v R]) #`#&R)) #&R) 381 | (check equal? (syntax->datum (quote-template ([$v R] [$u S]) #`#&$v$uT)) 382 | #&RST)) 383 | (test-case "syntax" 384 | (check equal? (syntax->datum (quote-template () #'#&X)) #&X) 385 | (check equal? (syntax->datum (quote-template ([$v R]) #'#&S)) #&S) 386 | (check equal? (syntax->datum (quote-template ([$v R]) #'#&$v)) #&R) 387 | (check equal? (syntax->datum (quote-template ([$v R] [$u S]) #'#&$v$uT)) 388 | #&RST)))) 389 | 390 | (test-suite "hash" 391 | (test-suite "with-template" 392 | (test-case "datum" 393 | (check equal? (with-template () #hash([X . 0])) #hash([X . 0])) 394 | (check equal? (with-template ([$k J]) #hash([K . 1])) #hash([K . 1])) 395 | (check equal? (with-template ([$k J]) #hash([$k . 1])) #hash([J . 1])) 396 | (check equal? (with-template ([$k J] [$v 2]) #hash([$k . $v])) 397 | #hash([J . 2]))) 398 | (test-case "quasisyntax" 399 | (check equal? (syntax->datum (with-template () #`#hash([X . 0]))) 400 | #hash([X . 0])) 401 | (check equal? (syntax->datum (with-template ([$k J]) #`#hash([K . 1]))) 402 | #hash([K . 1])) 403 | (check equal? (syntax->datum (with-template ([$k J]) #`#hash([$k . 1]))) 404 | #hash([J . 1])) 405 | (check equal? (syntax->datum (with-template ([$k J] [$v 2]) #`#hash([$k . $v]))) 406 | #hash([J . 2]))) 407 | (test-case "syntax" 408 | (check equal? (syntax->datum (with-template () #'#hash([X . 0]))) 409 | #hash([X . 0])) 410 | (check equal? (syntax->datum (with-template ([$k J]) #'#hash([K . 1]))) 411 | #hash([K . 1])) 412 | (check equal? (syntax->datum (with-template ([$k J]) #'#hash([$k . 1]))) 413 | #hash([J . 1])) 414 | (check equal? (syntax->datum (with-template ([$k J] [$v 2]) #'#hash([$k . $v]))) 415 | #hash([J . 2])))) 416 | (test-suite "quote-template" 417 | (test-case "datum" 418 | (check equal? (quote-template () #hash([X . 0])) #hash([X . 0])) 419 | (check equal? (quote-template ([$k J]) #hash([K . 1])) #hash([K . 1])) 420 | (check equal? (quote-template ([$k J]) #hash([$k . 1])) #hash([J . 1])) 421 | (check equal? (quote-template ([$k J] [$v 2]) #hash([$k . $v])) 422 | #hash([J . 2]))) 423 | (test-case "quasisyntax" 424 | (check equal? (syntax->datum (quote-template () #`#hash([X . 0]))) 425 | #hash([X . 0])) 426 | (check equal? (syntax->datum (quote-template ([$k J]) #`#hash([K . 1]))) 427 | #hash([K . 1])) 428 | (check equal? (syntax->datum (quote-template ([$k J]) #`#hash([$k . 1]))) 429 | #hash([J . 1])) 430 | (check equal? (syntax->datum (quote-template ([$k J] [$v 2]) #`#hash([$k . $v]))) 431 | #hash([J . 2]))) 432 | (test-case "syntax" 433 | (check equal? (syntax->datum (quote-template () #'#hash([X . 0]))) 434 | #hash([X . 0])) 435 | (check equal? (syntax->datum (quote-template ([$k J]) #'#hash([K . 1]))) 436 | #hash([K . 1])) 437 | (check equal? (syntax->datum (quote-template ([$k J]) #'#hash([$k . 1]))) 438 | #hash([J . 1])) 439 | (check equal? (syntax->datum (quote-template ([$k J] [$v 2]) #'#hash([$k . $v]))) 440 | #hash([J . 2]))))) 441 | 442 | (test-suite "prefab struct" 443 | (test-suite "with-template" 444 | (test-case "datum" 445 | (check equal? (with-template () #s(X)) #s(X)) 446 | (check equal? (with-template ([$x A]) #s(B 1)) #s(B 1)) 447 | (check equal? (with-template ([$x A]) #s($x 1)) #s(A 1)) 448 | (check equal? (with-template ([$x A] [$y 2]) #s($x$y3 $y)) #s(A23 2))) 449 | (test-case "quasisyntax" 450 | (check equal? (syntax->datum (with-template () #`#s(X 0))) #s(X 0)) 451 | (check equal? (syntax->datum (with-template ([$x A]) #`#s(B 1))) #s(B 1)) 452 | (check equal? (syntax->datum (with-template ([$x A]) #`#s($x 1))) #s(A 1)) 453 | (check equal? (syntax->datum (with-template ([$x A] [$y 2]) #`#s($x$y3 $y))) 454 | #s(A23 2))) 455 | (test-case "syntax" 456 | (check equal? (syntax->datum (with-template () #'#s(X 0))) #s(X 0)) 457 | (check equal? (syntax->datum (with-template ([$x A]) #'#s(B 1))) #s(B 1)) 458 | (check equal? (syntax->datum (with-template ([$x A]) #'#s($x 1))) #s(A 1)) 459 | (check equal? (syntax->datum (with-template ([$x A] [$y 2]) #'#s($x$y3 $y))) 460 | #s(A23 2)))) 461 | (test-suite "quote-template" 462 | (test-case "datum" 463 | (check equal? (quote-template () #s(X)) #s(X)) 464 | (check equal? (quote-template ([$x A]) #s(B 1)) #s(B 1)) 465 | (check equal? (quote-template ([$x A]) #s($x 1)) #s(A 1)) 466 | (check equal? (quote-template ([$x A] [$y 2]) #s($x$y3 $y)) #s(A23 2))) 467 | (test-case "quasisyntax" 468 | (check equal? (syntax->datum (quote-template () #`#s(X 0))) #s(X 0)) 469 | (check equal? (syntax->datum (quote-template ([$x A]) #`#s(B 1))) #s(B 1)) 470 | (check equal? (syntax->datum (quote-template ([$x A]) #`#s($x 1))) #s(A 1)) 471 | (check equal? (syntax->datum (quote-template ([$x A] [$y 2]) #`#s($x$y3 $y))) 472 | #s(A23 2))) 473 | (test-case "syntax" 474 | (check equal? (syntax->datum (quote-template () #'#s(X 0))) #s(X 0)) 475 | (check equal? (syntax->datum (quote-template ([$x A]) #'#s(B 1))) #s(B 1)) 476 | (check equal? (syntax->datum (quote-template ([$x A]) #'#s($x 1))) #s(A 1)) 477 | (check equal? (syntax->datum (quote-template ([$x A] [$y 2]) #'#s($x$y3 $y))) 478 | #s(A23 2)))))) 479 | 480 | (run-all-tests)) 481 | -------------------------------------------------------------------------------- /tests/module-templates.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (module+ test 18 | (require rackunit template (for-syntax racket/base)) 19 | 20 | (test-case "#lang template" 21 | (local-require template/scribblings/lang-template) 22 | (the-template a 3) 23 | (check equal? as '(a a a)) 24 | (check = a1 1) (check = a2 2) (check = a3 3)) 25 | 26 | (module test-module-template template/lang 27 | ($x $n) 28 | (require (for-syntax racket/base)) 29 | (define $xs '((for/template ([$_ (in-range 1 (add1 $n))]) $x))) 30 | (for/template ([$k (in-range 1 (add1 $n))]) 31 | (define $x$k $k))) 32 | 33 | (test-case "module template/lang" 34 | (local-require 'test-module-template) 35 | (the-template b 5) 36 | (check equal? bs '(b b b b b)) 37 | (check = b1 1) (check = b2 2) (check = b3 3) 38 | (check = b4 4) (check = b5 5)) 39 | 40 | (test-case "load-template" 41 | (load-template template/scribblings/lang-template tpl) 42 | (tpl c 6) 43 | (check equal? cs '(c c c c c c)) 44 | (check = c1 1) (check = c2 2) (check = c3 3) 45 | (check = c4 4) (check = c5 5) (check = c6 6))) 46 | -------------------------------------------------------------------------------- /tests/primitives.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (require template (for-syntax template)) 18 | 19 | (module+ test 20 | (require racket/function 21 | racket/string 22 | rackunit 23 | rackunit/text-ui 24 | syntax/macro-testing 25 | (for-syntax racket/base 26 | racket/sequence)) 27 | 28 | (provide the-tests) 29 | 30 | (define (run-all-tests) 31 | (run-tests the-tests) 32 | (void)) 33 | 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | (define-test-suite the-tests 37 | |expanding environments| |with-template tests| |quote-template tests|) 38 | 39 | (define-syntax X #'A) 40 | (define-syntax XY #'(A B)) 41 | (define-syntax ZW (list #'A #'B)) 42 | 43 | (define-test-suite |expanding environments| 44 | (test-case "template-expansion time is not macro-expansion time" 45 | (let-syntax ([z #'Z1]) 46 | (with-template () 47 | (let-syntax ([z #'Z2]) 48 | (check eq? '(untemplate (syntax-local-value #'z)) 'Z1) 49 | (check eq? 50 | (let-syntax ([go (λ _ #`'#,(syntax-local-value #'z))]) (go)) 51 | 'Z2)))))) 52 | 53 | (define-test-suite |with-template tests| 54 | (test-case "template variables are resolved" 55 | (check = (with-template ([$x 1] [$y 2]) $x$y3) 123)) 56 | (test-case "templates are expanded" 57 | (check eq? (with-template () '(with-template () X)) 'X)) 58 | (test-case "unsyntax escapes to the template-expanding environment" 59 | (check eq? (with-template () '#,(syntax-local-value #'X)) 'A)) 60 | (test-case "unsyntax-splicing escapes to the template-expanding environment" 61 | (check equal? (with-template () '(#,@(syntax-local-value #'XY))) '(A B)) 62 | (check equal? (with-template () '(#,@(syntax-local-value #'ZW))) '(A B))) 63 | (test-case "untemplate escapes to the template-expanding environment" 64 | (check eq? (with-template () '(untemplate (syntax-local-value #'X))) 'A)) 65 | (test-case "untemplate-splicing escapes to the template-expanding environment" 66 | (check equal? (with-template () '((untemplate-splicing (syntax-local-value #'XY)))) 67 | '(A B)) 68 | (check equal? (with-template () '((untemplate-splicing (syntax-local-value #'ZW)))) 69 | '(A B))) 70 | 71 | (test-suite "inside quasisyntax" 72 | (test-case "template variables are resolved" 73 | (check = (syntax-e (with-template ([$x 1] [$y 2]) #`$x$y3)) 123)) 74 | (test-case "templates are expanded" 75 | (check eq? (syntax-e (with-template () #`(with-template () X))) 'X)) 76 | (test-case "unsyntax escapes to the macro-expanding environment" 77 | (check-exn exn:fail:contract? 78 | (λ () (with-template () #`#,(syntax-local-value #'X)))) 79 | (check eq? (with-template () 80 | (let-syntax ([go (λ _ #`'#,(syntax-local-value #'X))]) (go))) 81 | 'A)) 82 | (test-case "unsyntax-splicing escapes to the macro-expanding environment" 83 | (check-exn exn:fail:contract? 84 | (λ () (with-template () #`(#,@(syntax-local-value #'XY))))) 85 | (define x1 86 | (with-template () 87 | (let-syntax ([go (λ _ #`'(#,@(syntax-local-value #'XY)))]) (go)))) 88 | (define x2 89 | (with-template () 90 | (let-syntax ([go (λ _ #`'(#,@(syntax-local-value #'ZW)))]) (go)))) 91 | (check equal? x1 '(A B)) 92 | (check equal? x2 '(A B))) 93 | (test-case "untemplate escapes to the template-expanding environment" 94 | (check equal? (syntax-e (with-template () #`(untemplate (syntax-local-value #'X)))) 95 | 'A)) 96 | (test-case "untemplate-splicing escapes to the template-expanding environment" 97 | (define stx1 (with-template () #`((untemplate-splicing (syntax-local-value #'XY))))) 98 | (define stx2 (with-template () #`((untemplate-splicing (syntax-local-value #'ZW))))) 99 | (check equal? (syntax->datum stx1) '(A B)) 100 | (check equal? (syntax->datum stx2) '(A B)))) 101 | 102 | (test-suite "inside syntax" 103 | (test-case "template variables are resolved" 104 | (check = (syntax-e (with-template ([$x 1] [$y 2]) #'$x$y3)) 123)) 105 | (test-case "templates are expanded" 106 | (check eq? (syntax-e (with-template () #'(with-template () X))) 'X)) 107 | (test-case "unsyntax does not escape to an expanding environment" 108 | (check equal? (syntax->datum (with-template () #'#,X)) '#,X)) 109 | (test-case "unsyntax-splicing does not escape to an expanding environment" 110 | (check equal? (syntax->datum (with-template () #'#,@XY)) '#,@XY)) 111 | (test-case "untemplate escapes to the template-expanding environment" 112 | (check equal? (syntax-e (with-template () #'(untemplate (syntax-local-value #'X)))) 113 | 'A)) 114 | (test-case "untemplate-splicing escapes to the template-expanding environment" 115 | (define stx1 (with-template () #'((untemplate-splicing (syntax-local-value #'XY))))) 116 | (define stx2 (with-template () #'((untemplate-splicing (syntax-local-value #'ZW))))) 117 | (check equal? (syntax->datum stx1) '(A B)) 118 | (check equal? (syntax->datum stx2) '(A B))))) 119 | 120 | (define-test-suite |quote-template tests| 121 | (test-case "template variables are resolved" 122 | (check = (syntax-e (quote-template ([$x 1] [$y 2]) #'$x$y3)) 123)) 123 | (test-case "templates are not expanded" 124 | (check equal? (quote-template () '(quote-template () X)) '(quote-template () X))) 125 | (test-case "unsyntax does not escape to an expanding environment" 126 | (check equal? 127 | (quote-template () '#,(syntax-local-value #'X)) 128 | '#,(syntax-local-value #'X))) 129 | (test-case "unsyntax-splicing does not escape to an expanding environment" 130 | (check equal? 131 | (quote-template () '(#,@(syntax-local-value #'XY))) 132 | '(#,@(syntax-local-value #'XY))) 133 | (check equal? 134 | (quote-template () '(#,@(syntax-local-value #'ZW))) 135 | '(#,@(syntax-local-value #'ZW)))) 136 | (test-case "untemplate does not escape to an expanding environment" 137 | (check equal? 138 | (quote-template () '(untemplate (syntax-local-value #'X))) 139 | '(untemplate (syntax-local-value #'X)))) 140 | (test-case "untemplate-splicing does not escape to an expanding environment" 141 | (check equal? 142 | (quote-template () '((untemplate-splicing (syntax-local-value #'XY)))) 143 | '((untemplate-splicing (syntax-local-value #'XY))))) 144 | 145 | (test-suite "inside quasisyntax" 146 | (test-case "template variables are resolved" 147 | (check = (syntax-e (quote-template ([$x 1] [$y 2]) #`$x$y3)) 123)) 148 | (test-case "templates are not expanded" 149 | (check-pred (negate number?) 150 | (syntax->datum (quote-template () #`(with-template () 1))))) 151 | (test-case "unsyntax escapes to the macro-expanding environment" 152 | (check-exn exn:fail:contract? 153 | (λ () (quote-template () #`#,(syntax-local-value #'X)))) 154 | (check eq? (quote-template () 155 | (let-syntax ([go (λ _ #`'#,(syntax-local-value #'X))]) (go))) 156 | 'A)) 157 | (test-case "unsyntax-splicing escapes to the macro-expanding environment" 158 | (check-exn exn:fail:contract? 159 | (λ () (quote-template () #`(#,@(syntax-local-value #'XY))))) 160 | (define x1 161 | (quote-template () 162 | (let-syntax ([go (λ _ #`'(#,@(syntax-local-value #'XY)))]) (go)))) 163 | (define x2 164 | (quote-template () 165 | (let-syntax ([go (λ _ #`'(#,@(syntax-local-value #'ZW)))]) (go)))) 166 | (check equal? x1 '(A B)) 167 | (check equal? x2 '(A B))) 168 | (test-case "untemplate does not escape to an expanding environment" 169 | (check (negate equal?) 170 | (syntax-e (quote-template () #`(untemplate (syntax-local-value #'X)))) 171 | 'A)) 172 | (test-case "untemplate-splicing does not escape to an expanding environment" 173 | (define stx1 (quote-template () #'((untemplate-splicing (syntax-local-value #'XY))))) 174 | (define stx2 (quote-template () #'((untemplate-splicing (syntax-local-value #'ZW))))) 175 | (check (negate equal?) (syntax->datum stx1) '(A B)) 176 | (check (negate equal?) (syntax->datum stx2) '(A B)))) 177 | 178 | (test-suite "inside syntax" 179 | (test-case "template variables are resolved" 180 | (check = (syntax-e (quote-template ([$x 1] [$y 2]) #'$x$y3)) 123)) 181 | (test-case "templates are not expanded" 182 | (check-pred (negate number?) 183 | (syntax->datum (quote-template () #'(with-template () 1))))) 184 | (test-case "unsyntax does not escape to an expanding environment" 185 | (check equal? (syntax->datum (quote-template () #'#,X)) '#,X)) 186 | (test-case "unsyntax-splicing does not escape to an expanding environment" 187 | (check equal? (syntax->datum (quote-template () #'#,@XY)) '#,@XY)) 188 | (test-case "untemplate does not escape to an expanding environment" 189 | (check (negate equal?) 190 | (syntax-e (quote-template () #'(untemplate (syntax-local-value #'X)))) 191 | 'A)) 192 | (test-case "untemplate-splicing does not escape to an expanding environment" 193 | (define stx1 (quote-template () #'((untemplate-splicing (syntax-local-value #'XY))))) 194 | (define stx2 (quote-template () #'((untemplate-splicing (syntax-local-value #'ZW))))) 195 | (check (negate equal?) (syntax->datum stx1) '(A B)) 196 | (check (negate equal?) (syntax->datum stx2) '(A B))))) 197 | 198 | (run-all-tests)) 199 | -------------------------------------------------------------------------------- /tests/scopes.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright 2020 Eric Griffis 2 | ;; 3 | ;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;; you may not use this file except in compliance with the License. 5 | ;; You may obtain a copy of the License at 6 | ;; 7 | ;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;; 9 | ;; Unless required by applicable law or agreed to in writing, software 10 | ;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;; See the License for the specific language governing permissions and 13 | ;; limitations under the License. 14 | 15 | #lang racket/base 16 | 17 | (require template (for-syntax racket/base template)) 18 | 19 | (module+ test 20 | (require racket/function 21 | rackunit 22 | rackunit/text-ui 23 | (for-syntax racket/base 24 | racket/sequence)) 25 | 26 | (provide the-tests) 27 | 28 | (define (run-all-tests) 29 | (run-tests the-tests) 30 | (void)) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | (define-test-suite the-tests primitives combiners) 35 | 36 | (define-test-suite primitives 37 | (test-case "static" 38 | (check free-identifier=? (with-template () #'X) #'X) 39 | (check bound-identifier=? (with-template () #'X) #'X) 40 | (check free-identifier=? 41 | (with-template () #'X) 42 | (with-template () #'X)) 43 | (check bound-identifier=? 44 | (with-template () #'X) 45 | (with-template () #'X))) 46 | 47 | (test-case "generated" 48 | (check free-identifier=? (with-template ([$x A]) #'$x$x) #'AA) 49 | (check bound-identifier=? (with-template ([$x A]) #'$x$x) #'AA) 50 | (check free-identifier=? 51 | (with-template ([$x A]) #'$x$x) 52 | (with-template ([$x A]) #'$x$x)) 53 | (check bound-identifier=? 54 | (with-template ([$x A]) #'$x$x) 55 | (with-template ([$x A]) #'$x$x))) 56 | 57 | (test-case "quote-generated" 58 | (check free-identifier=? (quote-template ([$x A]) #'$x$x) #'AA) 59 | (check bound-identifier=? (quote-template ([$x A]) #'$x$x) #'AA) 60 | (check free-identifier=? 61 | (quote-template ([$x A]) #'$x$x) 62 | (quote-template ([$x A]) #'$x$x)) 63 | (check bound-identifier=? 64 | (quote-template ([$x A]) #'$x$x) 65 | (quote-template ([$x A]) #'$x$x))) 66 | 67 | (test-case "untemplate-generated" 68 | (check free-identifier=? (with-template () #'(untemplate 'B)) #'B) 69 | (check bound-identifier=? (with-template () #'(untemplate 'B)) #'B) 70 | (check equal? (quote-template () '#`#,(untemplate ''B)) '#`#,(untemplate ''B)) 71 | (check free-identifier=? 72 | (with-template () #'(untemplate 'B)) 73 | (with-template () #'(untemplate 'B))) 74 | (check bound-identifier=? 75 | (with-template () #'(untemplate 'B)) 76 | (with-template () #'(untemplate 'B))) 77 | (check equal? 78 | (quote-template () '#`#,(untemplate ''B)) 79 | (quote-template () '#`#,(untemplate ''B))) 80 | (check free-identifier=? (with-template () #'(untemplate #'C)) #'C) 81 | (check (negate bound-identifier=?) (with-template () #'(untemplate #'C)) #'C) 82 | (check free-identifier=? 83 | (with-template () #'(untemplate #'C)) 84 | (with-template () #'(untemplate #'C))) 85 | (check (negate bound-identifier=?) 86 | (with-template () #'(untemplate #'C)) 87 | (with-template () #'(untemplate #'C))) 88 | (check equal? (quote-template () '#`#,(untemplate #''C)) '#`#,(untemplate #''C)) 89 | (check equal? 90 | (quote-template () '#`#,(untemplate #''C)) 91 | (quote-template () '#`#,(untemplate #''C))))) 92 | 93 | (define-test-suite combiners 94 | (test-case "begin-template" 95 | (check free-identifier=? (begin-template #'A) #'A) 96 | (check bound-identifier=? (begin-template #'A) #'A)) 97 | 98 | (test-case "begin0-template" 99 | (check free-identifier=? (begin0-template #'A) #'A) 100 | (check bound-identifier=? (begin0-template #'A) #'A)) 101 | 102 | (test-case "if-template" 103 | (check free-identifier=? (if-template #t #'A #'B) #'A) 104 | (check free-identifier=? (if-template #f #'A #'B) #'B) 105 | (check bound-identifier=? (if-template #t #'A #'B) #'A) 106 | (check bound-identifier=? (if-template #f #'A #'B) #'B)) 107 | 108 | (test-case "cond-template" 109 | (check free-identifier=? (cond-template [#t #'A] [#t #'B]) #'A) 110 | (check free-identifier=? (cond-template [#f #'A] [#t #'B]) #'B) 111 | (check free-identifier=? (cond-template [#t #'A] [#t #'B] [else #'C]) #'A) 112 | (check free-identifier=? (cond-template [#f #'A] [#t #'B] [else #'C]) #'B) 113 | (check free-identifier=? (cond-template [#f #'A] [#f #'B] [else #'C]) #'C) 114 | (check bound-identifier=? (cond-template [#t #'A] [#t #'B]) #'A) 115 | (check bound-identifier=? (cond-template [#f #'A] [#t #'B]) #'B) 116 | (check bound-identifier=? (cond-template [#t #'A] [#t #'B] [else #'C]) #'A) 117 | (check bound-identifier=? (cond-template [#f #'A] [#t #'B] [else #'C]) #'B) 118 | (check bound-identifier=? (cond-template [#f #'A] [#f #'B] [else #'C]) #'C)) 119 | 120 | (test-case "when-template" 121 | (check free-identifier=? (when-template #t #'A) #'A) 122 | (check bound-identifier=? (when-template #t #'A) #'A)) 123 | 124 | (test-case "unless-template" 125 | (check free-identifier=? (unless-template #f #'A) #'A) 126 | (check bound-identifier=? (unless-template #f #'A) #'A)) 127 | 128 | (test-case "for/template" 129 | (check (curry andmap free-identifier=?) 130 | (begin-template (list (for/template ([$x (in-syntax #'(A B C))]) #'$x))) 131 | (list #'A #'B #'C)) 132 | (check (curry andmap bound-identifier=?) 133 | (begin-template (list (for/template ([$x (in-syntax #'(A B C))]) #'$x))) 134 | (list #'A #'B #'C))) 135 | 136 | (test-case "for*/template" 137 | (check (curry andmap free-identifier=?) 138 | (begin-template (list (for*/template ([$x (in-syntax #'(A B C))] 139 | [$y (in-range 1 4)]) 140 | #'$x$y))) 141 | (list #'A1 #'A2 #'A3 #'B1 #'B2 #'B3 #'C1 #'C2 #'C3)) 142 | (check (curry andmap bound-identifier=?) 143 | (begin-template (list (for*/template ([$x (in-syntax #'(A B C))] 144 | [$y (in-range 1 4)]) 145 | #'$x$y))) 146 | (list #'A1 #'A2 #'A3 #'B1 #'B2 #'B3 #'C1 #'C2 #'C3)))) 147 | 148 | (module my-module-template template/lang ($x) #'$x) 149 | 150 | (define-test-suite modules 151 | (test-case "" 152 | (load-template 'my-module-template tpl) 153 | (check free-identifier=? (tpl M) #'M))) 154 | 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | 157 | (run-all-tests)) 158 | --------------------------------------------------------------------------------