├── .github └── workflows │ └── main.yml ├── .gitignore ├── LICENSE ├── README.md ├── indexed-traversal.rkt ├── info.rkt ├── lens.rkt ├── lens.scrbl ├── main.rkt ├── main.scrbl ├── prism.rkt ├── prism.scrbl ├── private ├── scribble-cross-document-tech.rkt └── scribble-evaluator-factory.rkt ├── traversal.rkt └── traversal.scrbl /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | racket-package-ci: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v1 10 | - uses: jackfirth/racket-package-ci-action@v0.1.4 11 | with: 12 | name: glass 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | doc/ 3 | -------------------------------------------------------------------------------- /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 | # glass [![CI Status][ci-status-badge]][ci-status] [![Documentation][docs-badge]][docs] 2 | 3 | An optics (lenses, prisms, traversals, etc.) library for Racket. 4 | 5 | This is just a fun experiment, I'm not seriously considering using this for now. 6 | This library is a hypothetical replacement for the `lens` package. 7 | 8 | [ci-status]: https://github.com/jackfirth/glass/actions 9 | [ci-status-badge]: https://github.com/jackfirth/glass/workflows/CI/badge.svg 10 | [docs]: https://docs.racket-lang.org/glass/index.html 11 | [docs-badge]: https://img.shields.io/badge/docs-published-blue.svg 12 | -------------------------------------------------------------------------------- /indexed-traversal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [indexed-traversal? predicate/c] 8 | [make-indexed-traversal 9 | (->* (#:getter (-> any/c immutable-vector?) 10 | #:indexer (-> any/c immutable-vector?) 11 | #:setter (-> any/c immutable-vector? any/c) 12 | #:counter (-> any/c natural?)) 13 | (#:name (or/c interned-symbol? #f)) 14 | indexed-traversal?)] 15 | [indexed-traversal-get-all (-> indexed-traversal? any/c immutable-vector?)] 16 | [indexed-traversal-set-all 17 | (-> indexed-traversal? any/c (sequence/c any/c) any/c)] 18 | [indexed-traversal-get-all-indices 19 | (-> indexed-traversal? any/c immutable-vector?)] 20 | [indexed-traversal-map 21 | (-> indexed-traversal? any/c (-> any/c any/c any/c) any/c)])) 22 | 23 | (require racket/math 24 | racket/sequence 25 | rebellion/base/symbol 26 | rebellion/collection/immutable-vector 27 | rebellion/collection/vector 28 | rebellion/private/static-name 29 | rebellion/type/object) 30 | 31 | (module+ test 32 | (require (submod "..") 33 | fancy-app 34 | rackunit)) 35 | 36 | ;@------------------------------------------------------------------------------ 37 | 38 | (define-object-type indexed-traversal 39 | (indexer getter setter counter) 40 | #:constructor-name constructor:indexed-traversal) 41 | 42 | (define (make-indexed-traversal 43 | #:getter getter 44 | #:indexer indexer 45 | #:setter setter 46 | #:counter [counter (λ (s) (immutable-vector-length (getter s)))] 47 | #:name [name #f]) 48 | (constructor:indexed-traversal 49 | #:getter (function-reduce-arity getter 1) 50 | #:indexer (function-reduce-arity indexer 1) 51 | #:setter (function-reduce-arity setter 2) 52 | #:counter (function-reduce-arity counter 1) 53 | #:name name)) 54 | 55 | (define (function-reduce-arity function expected-arity) 56 | (if (equal? (procedure-arity function) expected-arity) 57 | function 58 | (procedure-reduce-arity function expected-arity))) 59 | 60 | (define (indexed-traversal-get-all-indices traversal subject) 61 | ((indexed-traversal-indexer traversal) subject)) 62 | 63 | (define (indexed-traversal-get-all traversal subject) 64 | ((indexed-traversal-getter traversal) subject)) 65 | 66 | (define (indexed-traversal-count traversal subject) 67 | ((indexed-traversal-counter traversal) subject)) 68 | 69 | (define/name (indexed-traversal-set-all traversal subject foci) 70 | (define original-count (indexed-traversal-count traversal subject)) 71 | (define foci-vec (sequence->vector foci)) 72 | (define replacement-count (immutable-vector-length foci-vec)) 73 | (unless (equal? replacement-count original-count) 74 | (raise-arguments-error 75 | enclosing-function-name 76 | "traversals cannot be used to change the number of traversed elements" 77 | "traversal" traversal 78 | "original count" original-count 79 | "replacement count" replacement-count 80 | "subject" subject)) 81 | ((indexed-traversal-setter traversal) subject foci-vec)) 82 | 83 | (define (indexed-traversal-map traversal subject indexed-mapper) 84 | (define indices (indexed-traversal-get-all-indices traversal subject)) 85 | (define foci (indexed-traversal-get-all traversal subject)) 86 | (define count (immutable-vector-length indices)) 87 | (define replacements 88 | (for/vector #:length count 89 | ([i (in-vector indices)] 90 | [v (in-vector foci)]) 91 | (indexed-mapper i v))) 92 | (indexed-traversal-set-all traversal subject replacements)) 93 | 94 | (define/name hash-traversal 95 | (make-indexed-traversal 96 | #:getter 97 | (λ (h) (vector->immutable-vector (for/vector ([(_ v) (in-hash h)]) v))) 98 | #:indexer 99 | (λ (h) (vector->immutable-vector (for/vector ([(k _) (in-hash h)]) k))) 100 | #:setter 101 | (λ (h replacements) 102 | (for/hash ([(k _) (in-hash h)] [v (in-vector replacements)]) (values k v))) 103 | #:counter hash-count 104 | #:name enclosing-variable-name)) 105 | 106 | (module+ test 107 | (test-case (name-string hash-traversal) 108 | (define h (hash 'a 1 'b 2 'c 3)) 109 | (define show-entry (format "~a:~a" _ _)) 110 | (check-equal? 111 | (indexed-traversal-map hash-traversal h show-entry) 112 | (hash 'a "a:1" 'b "b:2" 'c "c:3")))) 113 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "glass") 4 | 5 | (define scribblings 6 | (list (list "main.scrbl" 7 | (list 'multi-page) 8 | (list 'library) 9 | "glass"))) 10 | 11 | (define deps 12 | (list "base" 13 | "fancy-app" 14 | "rebellion")) 15 | 16 | (define build-deps 17 | (list "racket-doc" 18 | "rackunit-lib" 19 | "scribble-lib")) 20 | -------------------------------------------------------------------------------- /lens.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [lens? predicate/c] 8 | [make-lens 9 | (->* ((-> any/c any/c) (-> any/c any/c any/c)) 10 | (#:name (or/c interned-symbol? #f)) 11 | lens?)] 12 | [lens-get (-> lens? any/c any/c)] 13 | [lens-set (-> lens? any/c any/c any/c)] 14 | [lens-map (-> lens? any/c (-> any/c any/c) any/c)] 15 | [lens/c (-> contract? contract? contract?)] 16 | [lens-pipe (-> lens? ... lens?)] 17 | [pair.first (lens/c pair? any/c)] 18 | [pair.second (lens/c pair? any/c)] 19 | [entry.key (lens/c entry? any/c)] 20 | [entry.value (lens/c entry? any/c)] 21 | [byte.bit (-> (integer-in 0 7) (lens/c byte? bit?))] 22 | [identity-lens lens?] 23 | [forward-converter-lens (-> converter? lens?)] 24 | [backward-converter-lens (-> converter? lens?)])) 25 | 26 | (require racket/bool 27 | racket/contract/combinator 28 | racket/match 29 | rebellion/base/converter 30 | rebellion/base/pair 31 | rebellion/base/symbol 32 | rebellion/binary/bit 33 | rebellion/binary/byte 34 | rebellion/collection/entry 35 | rebellion/collection/immutable-vector 36 | rebellion/private/contract-projection 37 | rebellion/private/impersonation 38 | rebellion/private/static-name 39 | rebellion/type/object) 40 | 41 | (module+ test 42 | (require (submod "..") 43 | rackunit)) 44 | 45 | ;@------------------------------------------------------------------------------ 46 | 47 | (define-object-type lens (getter setter) #:constructor-name constructor:lens) 48 | 49 | (define (make-lens getter setter #:name [name #f]) 50 | (constructor:lens 51 | #:getter (fix-getter-arity getter) 52 | #:setter (fix-setter-arity setter) 53 | #:name name)) 54 | 55 | (define (fix-getter-arity getter) 56 | (if (equal? (procedure-arity getter) 1) 57 | getter 58 | (procedure-reduce-arity getter 1))) 59 | 60 | (define (fix-setter-arity setter) 61 | (if (equal? (procedure-arity setter) 2) 62 | setter 63 | (procedure-reduce-arity setter 2))) 64 | 65 | (define (lens-get lens subject) ((lens-getter lens) subject)) 66 | 67 | (define (lens-set lens subject replacement-focus) 68 | ((lens-setter lens) subject replacement-focus)) 69 | 70 | ;@------------------------------------------------------------------------------ 71 | ;; Contracts 72 | 73 | (define (lens-impersonate 74 | lens 75 | #:subject-input-guard [subject-input-guard #f] 76 | #:subject-output-guard [subject-output-guard #f] 77 | #:focus-input-guard [focus-input-guard #f] 78 | #:focus-output-guard [focus-output-guard #f] 79 | #:properties [properties (hash)] 80 | #:get-marks [get-marks (hash)] 81 | #:set-marks [set-marks (hash)] 82 | #:chaperone? 83 | [chaperone? 84 | (nor subject-input-guard 85 | subject-output-guard 86 | focus-input-guard 87 | focus-output-guard)]) 88 | (define getter (lens-getter lens)) 89 | (define setter (lens-setter lens)) 90 | (define impersonated-getter 91 | (function-impersonate 92 | getter 93 | #:arguments-guard subject-input-guard 94 | #:results-guard focus-output-guard 95 | #:application-marks get-marks 96 | #:chaperone? chaperone?)) 97 | (define impersonated-setter 98 | (function-impersonate 99 | setter 100 | #:arguments-guard 101 | (λ (subject replacement-focus) 102 | (values (subject-input-guard subject) 103 | (focus-input-guard replacement-focus))) 104 | #:results-guard subject-output-guard 105 | #:application-marks set-marks 106 | #:chaperone? chaperone?)) 107 | (define impersonated-without-props 108 | (make-lens impersonated-getter impersonated-setter 109 | #:name (object-name lens))) 110 | (object-impersonate impersonated-without-props descriptor:lens 111 | #:properties properties)) 112 | 113 | (define/name (lens/c subject-contract* focus-contract*) 114 | (define subject-contract 115 | (coerce-contract enclosing-function-name subject-contract*)) 116 | (define focus-contract 117 | (coerce-contract enclosing-function-name focus-contract*)) 118 | (define contract-name 119 | (build-compound-type-name 120 | enclosing-function-name subject-contract focus-contract)) 121 | (define subject-projection (contract-late-neg-projection subject-contract)) 122 | (define focus-projection (contract-late-neg-projection focus-contract)) 123 | (define chaperone? 124 | (and (chaperone-contract? subject-contract) 125 | (chaperone-contract? focus-contract))) 126 | (define (projection blame) 127 | (define subject-input-blame 128 | (blame-add-context blame "an input lens subject of" 129 | #:swap? #t)) 130 | (define subject-output-blame 131 | (blame-add-context blame "an output lens subject of")) 132 | (define focus-output-blame 133 | (blame-add-context blame "an output lens focus of")) 134 | (define focus-input-blame 135 | (blame-add-context blame "an input lens focus of" #:swap? #t)) 136 | (define late-neg-subject-input-guard 137 | (subject-projection subject-input-blame)) 138 | (define late-neg-focus-output-guard (focus-projection focus-output-blame)) 139 | (define late-neg-focus-input-guard (focus-projection focus-input-blame)) 140 | (define late-neg-subject-output-guard 141 | (subject-projection subject-output-blame)) 142 | (λ (original-lens missing-party) 143 | (assert-satisfies original-lens lens? blame 144 | #:missing-party missing-party) 145 | (define props 146 | (hash impersonator-prop:contracted the-contract 147 | impersonator-prop:blame (cons blame missing-party))) 148 | (define (subject-input-guard input) 149 | (late-neg-subject-input-guard input missing-party)) 150 | (define (subject-output-guard output) 151 | (late-neg-subject-output-guard output missing-party)) 152 | (define (focus-input-guard input) 153 | (late-neg-focus-input-guard input missing-party)) 154 | (define (focus-output-guard output) 155 | (late-neg-focus-output-guard output missing-party)) 156 | (lens-impersonate 157 | original-lens 158 | #:subject-input-guard subject-input-guard 159 | #:subject-output-guard subject-output-guard 160 | #:focus-input-guard focus-input-guard 161 | #:focus-output-guard focus-output-guard 162 | #:chaperone? chaperone? 163 | #:properties props))) 164 | (define the-contract 165 | ((if chaperone? make-chaperone-contract make-contract) 166 | #:name contract-name 167 | #:first-order lens? 168 | #:late-neg-projection projection)) 169 | the-contract) 170 | 171 | ;@------------------------------------------------------------------------------ 172 | ;; More lens constructors 173 | 174 | (define/name (forward-converter-lens converter) 175 | (make-lens (λ (subject) (convert-forward converter subject)) 176 | (λ (_ replacement-focus) 177 | (convert-backward converter replacement-focus)) 178 | #:name enclosing-function-name)) 179 | 180 | (define/name (backward-converter-lens converter) 181 | (make-lens (λ (subject) (convert-backward converter subject)) 182 | (λ (_ replacement-focus) 183 | (convert-forward converter replacement-focus)) 184 | #:name enclosing-function-name)) 185 | 186 | (module+ test 187 | (test-case (name-string forward-converter-lens) 188 | (define string.symbol (forward-converter-lens string<->symbol)) 189 | (check-equal? (lens-get string.symbol "foo") 'foo) 190 | (check-equal? (lens-set string.symbol "unused" 'foo) "foo")) 191 | 192 | (test-case (name-string backward-converter-lens) 193 | (define symbol.string (backward-converter-lens string<->symbol)) 194 | (check-equal? (lens-get symbol.string 'bar) "bar") 195 | (check-equal? (lens-set symbol.string 'unused "bar") 'bar))) 196 | 197 | (define (lens-pipe-getter outer-lens inner-lens) 198 | (define outer-getter (lens-getter outer-lens)) 199 | (define inner-getter (lens-getter inner-lens)) 200 | (λ (subject) (inner-getter (outer-getter subject)))) 201 | 202 | (define (lens-pipe-setter outer-lens inner-lens) 203 | (define outer-getter (lens-getter outer-lens)) 204 | (define outer-setter (lens-setter outer-lens)) 205 | (define inner-setter (lens-setter inner-lens)) 206 | (λ (subject replacement) 207 | (define outer-replacement (inner-setter (outer-getter subject) replacement)) 208 | (outer-setter subject outer-replacement))) 209 | 210 | (define (lens-pipe2 outer-lens inner-lens) 211 | (define getter (lens-pipe-getter outer-lens inner-lens)) 212 | (define setter (lens-pipe-setter outer-lens inner-lens)) 213 | (make-lens getter setter #:name 'piped)) 214 | 215 | (define (lens-pipe . lenses) 216 | (match lenses 217 | ['() identity-lens] 218 | [(list lens) lens] 219 | [(cons first-lens remaining-lenses) 220 | (for/fold ([piped first-lens]) ([lens remaining-lenses]) 221 | (lens-pipe2 piped lens))])) 222 | 223 | (module+ test 224 | (test-case (name-string lens-pipe) 225 | 226 | (test-case "identity lens" 227 | (check-equal? (lens-pipe) identity-lens)) 228 | 229 | (test-case "single lens" 230 | (check-equal? (lens-pipe entry.key) entry.key)) 231 | 232 | (test-case "two lenses" 233 | (define entry.value.first-bit (lens-pipe entry.value (byte.bit 0))) 234 | (define data (entry 'a (byte 0 0 0 0 0 0 0 0))) 235 | (define expected (entry 'a (byte 1 0 0 0 0 0 0 0))) 236 | (check-equal? (lens-get entry.value.first-bit data) 0) 237 | (check-equal? (lens-set entry.value.first-bit data 1) expected)) 238 | 239 | (test-case "many lenses" 240 | (define entry.value.key.first-bit 241 | (lens-pipe entry.value entry.key (byte.bit 0))) 242 | (define data (entry 'a (entry (byte 0 0 0 0 0 0 0 0) 'b))) 243 | (define expected (entry 'a (entry (byte 1 0 0 0 0 0 0 0) 'b))) 244 | (check-equal? (lens-get entry.value.key.first-bit data) 0) 245 | (check-equal? (lens-set entry.value.key.first-bit data 1) expected)))) 246 | 247 | ;@------------------------------------------------------------------------------ 248 | ;; Standard library lenses 249 | 250 | (define/name identity-lens 251 | (make-lens values (λ (_ v) v) #:name enclosing-variable-name)) 252 | 253 | (module+ test 254 | (test-case (name-string identity-lens) 255 | (check-equal? (lens-get identity-lens 4) 4) 256 | (check-equal? (lens-set identity-lens 'unused 3) 3))) 257 | 258 | (define/name pair.first 259 | (make-lens pair-first (λ (p v) (pair v (pair-second p))) 260 | #:name enclosing-variable-name)) 261 | 262 | (define/name pair.second 263 | (make-lens pair-second (λ (p v) (pair (pair-first p) v)) 264 | #:name enclosing-variable-name)) 265 | 266 | (define/name entry.key 267 | (make-lens entry-key (λ (e k) (entry k (entry-value e))) 268 | #:name enclosing-variable-name)) 269 | 270 | (define/name entry.value 271 | (make-lens entry-value (λ (e v) (entry (entry-key e) v)) 272 | #:name enclosing-variable-name)) 273 | 274 | (module+ test 275 | (test-case (name-string pair.first) 276 | (check-equal? (lens-get pair.first (pair 'a 1)) 'a) 277 | (check-equal? (lens-set pair.first (pair 'a 1) 'b) (pair 'b 1))) 278 | 279 | (test-case (name-string pair.second) 280 | (check-equal? (lens-get pair.second (pair 'a 1)) 1) 281 | (check-equal? (lens-set pair.second (pair 'a 1) 2) (pair 'a 2))) 282 | 283 | (test-case (name-string entry.key) 284 | (check-equal? (lens-get entry.key (entry 'a 1)) 'a) 285 | (check-equal? (lens-set entry.key (entry 'a 1) 'b) (entry 'b 1))) 286 | 287 | (test-case (name-string entry.value) 288 | (check-equal? (lens-get entry.value (entry 'a 1)) 1) 289 | (check-equal? (lens-set entry.value (entry 'a 1) 2) (entry 'a 2)))) 290 | 291 | 292 | (define (byte-set-first b bit) 293 | (if (zero? bit) 294 | (byte-and b (byte 0 1 1 1 1 1 1 1)) 295 | (byte-or b (byte 1 0 0 0 0 0 0 0)))) 296 | 297 | (define (byte-set-second b bit) 298 | (if (zero? bit) 299 | (byte-and b (byte 1 0 1 1 1 1 1 1)) 300 | (byte-or b (byte 0 1 0 0 0 0 0 0)))) 301 | 302 | (define (byte-set-third b bit) 303 | (if (zero? bit) 304 | (byte-and b (byte 1 1 0 1 1 1 1 1)) 305 | (byte-or b (byte 0 0 1 0 0 0 0 0)))) 306 | 307 | (define (byte-set-fourth b bit) 308 | (if (zero? bit) 309 | (byte-and b (byte 1 1 1 0 1 1 1 1)) 310 | (byte-or b (byte 0 0 0 1 0 0 0 0)))) 311 | 312 | (define (byte-set-fifth b bit) 313 | (if (zero? bit) 314 | (byte-and b (byte 1 1 1 1 0 1 1 1)) 315 | (byte-or b (byte 0 0 0 0 1 0 0 0)))) 316 | 317 | (define (byte-set-sixth b bit) 318 | (if (zero? bit) 319 | (byte-and b (byte 1 1 1 1 1 0 1 1)) 320 | (byte-or b (byte 0 0 0 0 0 1 0 0)))) 321 | 322 | (define (byte-set-seventh b bit) 323 | (if (zero? bit) 324 | (byte-and b (byte 1 1 1 1 1 1 0 1)) 325 | (byte-or b (byte 0 0 0 0 0 0 1 0)))) 326 | 327 | (define (byte-set-eighth b bit) 328 | (if (zero? bit) 329 | (byte-and b (byte 1 1 1 1 1 1 1 0)) 330 | (byte-or b (byte 0 0 0 0 0 0 0 1)))) 331 | 332 | (define byte-setters 333 | (immutable-vector 334 | byte-set-first 335 | byte-set-second 336 | byte-set-third 337 | byte-set-fourth 338 | byte-set-fifth 339 | byte-set-sixth 340 | byte-set-seventh 341 | byte-set-eighth)) 342 | 343 | (define/name (byte.bit pos) 344 | (make-lens (λ (b) (byte-ref b pos)) (vector-ref byte-setters pos) 345 | #:name enclosing-function-name)) 346 | 347 | (module+ test 348 | (test-case (name-string byte.bit) 349 | (define byte.third-bit (byte.bit 2)) 350 | (check-equal? (lens-get byte.third-bit (byte 0 0 1 0 0 0 0 0)) 1) 351 | (check-equal? (lens-get byte.third-bit (byte 0 0 0 0 0 0 0 0)) 0) 352 | (check-equal? 353 | (lens-set byte.third-bit (byte 1 1 1 1 0 0 0 0) 0) (byte 1 1 0 1 0 0 0 0)) 354 | (check-equal? 355 | (lens-set byte.third-bit (byte 1 1 1 1 0 0 0 0) 1) 356 | (byte 1 1 1 1 0 0 0 0)))) 357 | 358 | ;@------------------------------------------------------------------------------ 359 | ;; More ways of using lenses 360 | 361 | (define (lens-map lens subject mapper) 362 | (lens-set lens subject (mapper (lens-get lens subject)))) 363 | 364 | (module+ test 365 | (test-case (name-string lens-map) 366 | (check-equal? (lens-map pair.first (pair 4 7) -) (pair -4 7)))) 367 | -------------------------------------------------------------------------------- /lens.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label glass/lens 4 | (except-in racket/base pair?) 5 | racket/contract/base 6 | rebellion/base/pair 7 | rebellion/base/symbol 8 | rebellion/binary/bit 9 | rebellion/binary/byte 10 | rebellion/collection/entry 11 | rebellion/type/tuple) 12 | (submod glass/private/scribble-cross-document-tech doc) 13 | (submod glass/private/scribble-evaluator-factory doc) 14 | scribble/example) 15 | 16 | @(define make-evaluator 17 | (make-module-sharing-evaluator-factory 18 | #:public (list 'glass/lens 19 | 'rebellion/base/pair 20 | 'rebellion/binary/byte 21 | 'rebellion/collection/entry 22 | 'rebellion/type/tuple) 23 | #:private (list 'racket/base))) 24 | 25 | @title{Lenses} 26 | @defmodule[glass/lens] 27 | 28 | A @deftech{lens} is a type of @tech{optic} for focusing on small parts of a 29 | subject. A lens is built from a getter function, which extracts the focus from 30 | the subject, and a setter function, which takes a subject and a replacement for 31 | the focus and builds a new subject. 32 | 33 | @defproc[(lens? [v any/c]) boolean?]{ 34 | A predicate for @tech[#:key "lens"]{lenses}.} 35 | 36 | @defproc[ 37 | (make-lens 38 | [getter (-> any/c any/c)] 39 | [setter (-> any/c any/c any/c)] 40 | [#:name name (or/c interned-symbol? #f) #f]) 41 | lens?]{ 42 | Constructs a @tech{lens} named @racket[name] that focuses on subjects by 43 | calling @racket[getter] on the subject and updates the focus by calling 44 | @racket[setter] with the subject and the replacement focus. 45 | 46 | @(examples 47 | #:eval (make-evaluator) #:once 48 | (eval:no-prompt 49 | (define-tuple-type point (x y)) 50 | (define point.x 51 | (make-lens point-x (λ (p x) (point x (point-y p))) #:name 'point.x))) 52 | 53 | (lens-get point.x (point 4 7)) 54 | (lens-set point.x (point 4 7) 100))} 55 | 56 | @defproc[(lens-get [lens lens?] [subject any/c]) any/c]{ 57 | Returns the focus of @racket[lens] on @racket[subject].} 58 | 59 | @defproc[(lens-set [lens lens?] [subject any/c] [replacement any/c]) any/c]{ 60 | Updates @racket[subject] with @racket[lens] by replacing its focus with 61 | @racket[replacement], returning an updated subject.} 62 | 63 | @defproc[(lens-map [lens lens?] [subject any/c] [mapper (-> any/c any/c)]) 64 | any/c]{ 65 | Updates @racket[subject] with @racket[lens] by applying @racket[mapper] to its 66 | focus, returning an updated subject with the mapped focus. 67 | 68 | @(examples 69 | #:eval (make-evaluator) #:once 70 | (lens-map entry.value (entry 'a 16) sqrt))} 71 | 72 | @defproc[(lens/c [subject-contract contract?] [focus-contract contract?]) 73 | contract?]{ 74 | A @reference-tech{contract combinator} for @tech[#:key "lens"]{lenses}. Creates 75 | a contract that accepts lenses whose subjects are checked with 76 | @racket[subject-contract] and whose foci are checked with 77 | @racket[focus-contract].} 78 | 79 | @defthing[identity-lens lens?]{ 80 | The identity @tech{lens}, which focuses on the entire subject and replaces it 81 | entirely when given a new focus. 82 | 83 | @(examples 84 | #:eval (make-evaluator) #:once 85 | (lens-get identity-lens 5) 86 | (lens-set identity-lens 5 100))} 87 | 88 | @defproc[(lens-pipe [lens lens?] ...) lens?]{ 89 | Joins each @racket[lens] to the next, building a composed lens that focuses on 90 | subjects by recursively focusing on the subject once with each lens from left 91 | to right. If only one lens is given, it is returned unchanged, and if no lenses 92 | are given, @racket[identity-lens] is returned. 93 | 94 | @(examples 95 | #:eval (make-evaluator) #:once 96 | (eval:no-prompt (define entry.key.first (lens-pipe entry.key pair.first))) 97 | (lens-get entry.key.first (entry (pair 'a 'c) 5)) 98 | (lens-set entry.key.first (entry (pair 'a 'c) 5) 'f))} 99 | 100 | @deftogether[[ 101 | @defthing[pair.first (lens/c pair? any/c)] 102 | @defthing[pair.second (lens/c pair? any/c)]]]{ 103 | Lenses that focus on the first and second values of a @rebellion-tech{pair}, 104 | respectively. 105 | 106 | @(examples 107 | #:eval (make-evaluator) #:once 108 | (lens-get pair.first (pair 4 8)) 109 | (lens-set pair.second (pair 4 8) 100))} 110 | 111 | @deftogether[[ 112 | @defthing[entry.key (lens/c entry? any/c)] 113 | @defthing[entry.value (lens/c entry? any/c)]]]{ 114 | Lenses that focus on the key and value of an @rebellion-tech{entry}, 115 | respectively. 116 | 117 | @(examples 118 | #:eval (make-evaluator) #:once 119 | (lens-get entry.key (entry 'a 1)) 120 | (lens-set entry.value (entry 'a 1) 5))} 121 | 122 | @defproc[(byte.bit [position (integer-in 0 7)]) (lens/c byte? bit?)]{ 123 | Constructs a @tech{lens} that focuses on the bit at @racket[position] in a 124 | byte, with bit positions numbered from left to right. 125 | 126 | @(examples 127 | #:eval (make-evaluator) #:once 128 | (lens-get (byte.bit 7) (byte 1 1 1 1 1 1 1 0)) 129 | (lens-set (byte.bit 7) (byte 0 0 0 0 0 0 0 0) 1))} 130 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | -------------------------------------------------------------------------------- /main.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label glass 4 | glass/lens 5 | glass/prism 6 | glass/traversal) 7 | (submod glass/private/scribble-cross-document-tech doc)) 8 | 9 | @title{Glass: Composable Optics} 10 | @defmodule[glass] 11 | 12 | This is an experimental library for optics. An @deftech{optic} is an object for 13 | viewing one form of data, called the @deftech{subject}, in some other form, 14 | called a @deftech{focus}. Optics are bidirectional: in addition to viewing the 15 | focus, optics allow @emph{changing} the focus to get a new, updated subject. 16 | There are several different kinds of optics, each of which expresses a different 17 | relationship between subject and focus: 18 | 19 | @itemlist[ 20 | @item{@tech[#:key "lens"]{Lenses} focus on one small part of the subject, such 21 | as a field of a struct. Other parts of the subject are left untouched when the 22 | focus is changed. For example, the @racket[entry.key] lens focuses on the key 23 | of an @rebellion-tech{entry} object, allowing you to change the key of an 24 | entry.} 25 | 26 | @item{@tech{Prisms} focus on one specific kind of subject, such as a subtype of 27 | a struct. Other kinds of subjects are ignored. For example, 28 | @racket[success-prism] focuses on successful @rebellion-tech{result} objects 29 | and ignores failed ones, allowing you to change the values inside only 30 | successful results.} 31 | 32 | @item{@tech{Traversals} focus on several parts of the subject at once, such as 33 | the characters of a string. Each focus can be updated to a new value, but a 34 | traversal cannot change the total number of foci.}] 35 | 36 | I'm working on this library for fun as a hypothetical successor to the 37 | @racketmodname[lens #:indirect] library. I might put more work into it, or I 38 | might not. Absolutely no promise of backwards compatibility whatsoever. Caveat 39 | emptor. 40 | 41 | @include-section[(lib "glass/lens.scrbl")] 42 | @include-section[(lib "glass/prism.scrbl")] 43 | @include-section[(lib "glass/traversal.scrbl")] 44 | -------------------------------------------------------------------------------- /prism.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [prism? predicate/c] 8 | [make-prism 9 | (->* ((-> any/c option?) (-> any/c any/c)) 10 | (#:name (or/c interned-symbol? #f)) 11 | prism?)] 12 | [prism-match (-> prism? any/c option?)] 13 | [prism-cast (-> prism? any/c any/c)] 14 | [prism/c (-> contract? contract? contract?)] 15 | [identity-prism prism?] 16 | [present-prism (prism/c option? any/c)] 17 | [success-prism (prism/c result? any/c)] 18 | [failure-prism (prism/c result? any/c)] 19 | [predicate-prism 20 | (->i ([predicate predicate/c]) [_ (predicate) (prism/c any/c predicate)])])) 21 | 22 | (require racket/bool 23 | racket/contract/combinator 24 | racket/match 25 | rebellion/base/converter 26 | rebellion/base/option 27 | rebellion/base/result 28 | rebellion/base/symbol 29 | rebellion/binary/bit 30 | rebellion/binary/byte 31 | rebellion/collection/entry 32 | rebellion/collection/immutable-vector 33 | rebellion/private/contract-projection 34 | rebellion/private/impersonation 35 | rebellion/private/static-name 36 | rebellion/type/object) 37 | 38 | (module+ test 39 | (require (submod "..") 40 | rackunit)) 41 | 42 | ;@------------------------------------------------------------------------------ 43 | 44 | (define-object-type prism (matcher caster) #:constructor-name constructor:prism) 45 | 46 | (define (make-prism matcher caster #:name [name #f]) 47 | (constructor:prism 48 | #:matcher (fix-arity matcher) 49 | #:caster (fix-arity caster) 50 | #:name name)) 51 | 52 | (define (prism-match prism subject) ((prism-matcher prism) subject)) 53 | (define (prism-cast prism focus) ((prism-caster prism) focus)) 54 | 55 | (define (fix-arity prism-function) 56 | (if (equal? (procedure-arity prism-function) 1) 57 | prism-function 58 | (procedure-reduce-arity prism-function 1))) 59 | 60 | ;@------------------------------------------------------------------------------ 61 | ;; Contracts 62 | 63 | (define (prism-impersonate 64 | prism 65 | #:subject-input-guard [subject-input-guard #f] 66 | #:subject-output-guard [subject-output-guard #f] 67 | #:focus-input-guard [focus-input-guard #f] 68 | #:focus-output-guard [focus-output-guard #f] 69 | #:properties [properties (hash)] 70 | #:match-marks [match-marks (hash)] 71 | #:cast-marks [cast-marks (hash)] 72 | #:chaperone? 73 | [chaperone? 74 | (nor subject-input-guard 75 | subject-output-guard 76 | focus-input-guard 77 | focus-output-guard)]) 78 | (define matcher (prism-matcher prism)) 79 | (define caster (prism-caster prism)) 80 | (define impersonated-matcher 81 | (function-impersonate 82 | matcher 83 | #:arguments-guard subject-input-guard 84 | #:results-guard (λ (opt) (option-map opt focus-output-guard)) 85 | #:application-marks match-marks 86 | #:chaperone? chaperone?)) 87 | (define impersonated-caster 88 | (function-impersonate 89 | caster 90 | #:arguments-guard focus-input-guard 91 | #:results-guard subject-output-guard 92 | #:application-marks cast-marks 93 | #:chaperone? chaperone?)) 94 | (define impersonated-without-props 95 | (make-prism impersonated-matcher impersonated-caster 96 | #:name (object-name prism))) 97 | (object-impersonate impersonated-without-props descriptor:prism 98 | #:properties properties)) 99 | 100 | (define/name (prism/c subject-contract* focus-contract*) 101 | (define subject-contract 102 | (coerce-contract enclosing-function-name subject-contract*)) 103 | (define focus-contract 104 | (coerce-contract enclosing-function-name focus-contract*)) 105 | (define contract-name 106 | (build-compound-type-name 107 | enclosing-function-name subject-contract focus-contract)) 108 | (define subject-projection (contract-late-neg-projection subject-contract)) 109 | (define focus-projection (contract-late-neg-projection focus-contract)) 110 | (define chaperone? 111 | (and (chaperone-contract? subject-contract) 112 | (chaperone-contract? focus-contract))) 113 | (define (projection blame) 114 | (define subject-input-blame 115 | (blame-add-context blame "an input prism subject of" 116 | #:swap? #t)) 117 | (define subject-output-blame 118 | (blame-add-context blame "an output prism subject of")) 119 | (define focus-output-blame 120 | (blame-add-context blame "an output prism focus of")) 121 | (define focus-input-blame 122 | (blame-add-context blame "an input prism focus of" #:swap? #t)) 123 | (define late-neg-subject-input-guard 124 | (subject-projection subject-input-blame)) 125 | (define late-neg-focus-output-guard (focus-projection focus-output-blame)) 126 | (define late-neg-focus-input-guard (focus-projection focus-input-blame)) 127 | (define late-neg-subject-output-guard 128 | (subject-projection subject-output-blame)) 129 | (λ (original-prism missing-party) 130 | (assert-satisfies original-prism prism? blame 131 | #:missing-party missing-party) 132 | (define props 133 | (hash impersonator-prop:contracted the-contract 134 | impersonator-prop:blame (cons blame missing-party))) 135 | (define (subject-input-guard input) 136 | (late-neg-subject-input-guard input missing-party)) 137 | (define (subject-output-guard output) 138 | (late-neg-subject-output-guard output missing-party)) 139 | (define (focus-input-guard input) 140 | (late-neg-focus-input-guard input missing-party)) 141 | (define (focus-output-guard output) 142 | (late-neg-focus-output-guard output missing-party)) 143 | (prism-impersonate 144 | original-prism 145 | #:subject-input-guard subject-input-guard 146 | #:subject-output-guard subject-output-guard 147 | #:focus-input-guard focus-input-guard 148 | #:focus-output-guard focus-output-guard 149 | #:chaperone? chaperone? 150 | #:properties props))) 151 | (define the-contract 152 | ((if chaperone? make-chaperone-contract make-contract) 153 | #:name contract-name 154 | #:first-order prism? 155 | #:late-neg-projection projection)) 156 | the-contract) 157 | 158 | ;@------------------------------------------------------------------------------ 159 | ;; More prism constructors 160 | 161 | (define (predicate-prism predicate) 162 | (make-prism (λ (v) (if (predicate v) (present v) absent)) values 163 | #:name (object-name predicate))) 164 | 165 | (module+ test 166 | (test-case (name-string predicate-prism) 167 | (define only-strings (predicate-prism string?)) 168 | (check-equal? (prism-match only-strings "foo") (present "foo")) 169 | (check-equal? (prism-match only-strings 420) absent) 170 | (check-equal? (prism-cast only-strings "foo") "foo"))) 171 | 172 | ;@------------------------------------------------------------------------------ 173 | ;; Standard library prisms 174 | 175 | (define/name identity-prism 176 | (make-prism present values #:name enclosing-variable-name)) 177 | 178 | (module+ test 179 | (test-case (name-string identity-prism) 180 | (check-equal? (prism-match identity-prism 4) (present 4)) 181 | (check-equal? (prism-cast identity-prism 'foo) 'foo))) 182 | 183 | 184 | (define/name present-prism 185 | (make-prism values present #:name enclosing-variable-name)) 186 | 187 | (define (success-value res) 188 | (match res [(success v) (present v)] [(failure _) absent])) 189 | 190 | (define/name success-prism 191 | (make-prism success-value success #:name enclosing-variable-name)) 192 | 193 | (define (failure-error res) 194 | (match res [(failure e) (present e)] [(success _) absent])) 195 | 196 | (define/name failure-prism 197 | (make-prism failure-error failure #:name enclosing-variable-name)) 198 | 199 | (module+ test 200 | (test-case (name-string present-prism) 201 | (check-equal? (prism-match present-prism (present 5)) (present 5)) 202 | (check-equal? (prism-match present-prism absent) absent) 203 | (check-equal? (prism-cast present-prism 5) (present 5))) 204 | 205 | (test-case (name-string success-prism) 206 | (check-equal? (prism-match success-prism (success 420)) (present 420)) 207 | (check-equal? (prism-match success-prism (failure 'boom)) absent) 208 | (check-equal? (prism-cast success-prism 420) (success 420))) 209 | 210 | (test-case (name-string failure-prism) 211 | (check-equal? (prism-match failure-prism (failure 'boom)) (present 'boom)) 212 | (check-equal? (prism-match failure-prism (success 420)) absent) 213 | (check-equal? (prism-cast failure-prism 'boom) (failure 'boom)))) 214 | -------------------------------------------------------------------------------- /prism.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label glass/prism 4 | racket/base 5 | racket/contract/base 6 | rebellion/base/option 7 | rebellion/base/result 8 | rebellion/base/symbol) 9 | (submod glass/private/scribble-cross-document-tech doc) 10 | (submod glass/private/scribble-evaluator-factory doc) 11 | scribble/example) 12 | 13 | @(define make-evaluator 14 | (make-module-sharing-evaluator-factory 15 | #:public (list 'glass/prism 16 | 'rebellion/base/option 17 | 'rebellion/base/result) 18 | #:private (list 'racket/base))) 19 | 20 | @title{Prisms} 21 | @defmodule[glass/prism] 22 | 23 | A @deftech{prism} is a type of @tech{optic} for focusing on a specific kind of 24 | subject and ignoring other kinds. A prism is built from a matching function, 25 | which focuses on subjects of the correct kind, and a casting function, which 26 | transforms a replacement focus back into the subject. 27 | 28 | @defproc[(prism? [v any/c]) boolean?]{ 29 | A predicate for @tech{prisms}.} 30 | 31 | @defproc[(prism/c [subject-contract contract?] [focus-contract contract?]) 32 | contract?]{ 33 | A @reference-tech{contract combinator} for @tech{prisms}. Creates a contract 34 | that accepts prisms whose subjects are checked with @racket[subject-contract] 35 | and whose foci are checked with @racket[focus-contract].} 36 | 37 | @defproc[(make-prism 38 | [matcher (-> any/c option?)] 39 | [caster (-> any/c any/c)] 40 | [#:name name (or/c interned-symbol? #f) #f]) 41 | prism?]{ 42 | Constructs a @tech{prism} named @racket[name]. 43 | 44 | @(examples 45 | #:eval (make-evaluator) #:once 46 | (eval:no-prompt 47 | (define number-string-prism 48 | (make-prism 49 | (λ (s) 50 | (define num (string->number s)) 51 | (if num (present num) absent)) 52 | number->string 53 | #:name 'number-string-prism))) 54 | 55 | (prism-match number-string-prism "124") 56 | (prism-match number-string-prism "elephant") 57 | (prism-cast number-string-prism 100))} 58 | 59 | @defproc[(prism-match [prism prism?] [subject any/c]) option?]{ 60 | Matches @racket[subject] against @racket[prism], returning an 61 | @rebellion-tech{option} that is present if @racket[prism] was able to extract a 62 | focus from @racket[subject] and absent otherwise. 63 | 64 | @(examples 65 | #:eval (make-evaluator) #:once 66 | (prism-match success-prism (success 123)) 67 | (prism-match success-prism (failure "oh no!")))} 68 | 69 | @defproc[(prism-cast [prism prism?] [focus any/c]) any/c]{ 70 | Casts @racket[focus] back into a subject value using @racket[prism]. This is 71 | the inverse operation of @racket[prism-match] --- if @racket[prism-match] 72 | successfully extracts a value from a subject, that value can be converted back 73 | to the original subject using @racket[prism-cast]. 74 | 75 | @(examples 76 | #:eval (make-evaluator) #:once 77 | (prism-cast success-prism 123))} 78 | 79 | @deftogether[[ 80 | @defthing[success-prism (prism/c result? any/c)] 81 | @defthing[failure-prism (prism/c result? any/c)]]]{ 82 | Two @tech{prisms} which focus on successful and failed @rebellion-tech{result} 83 | values, respectively. 84 | 85 | @(examples 86 | #:eval (make-evaluator) #:once 87 | (prism-match success-prism (failure "kaboom!")) 88 | (prism-match failure-prism (failure "kaboom!")) 89 | (prism-cast failure-prism "kaboom!"))} 90 | -------------------------------------------------------------------------------- /private/scribble-cross-document-tech.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module doc racket/base 4 | 5 | (require racket/contract/base) 6 | 7 | (provide 8 | (contract-out 9 | [reference-tech cross-document-tech-function/c] 10 | [rebellion-tech cross-document-tech-function/c])) 11 | 12 | (require rebellion/base/immutable-string 13 | scribble/base 14 | scribble/core 15 | scribble/decode 16 | scribble/manual) 17 | 18 | ;@---------------------------------------------------------------------------- 19 | 20 | (define cross-document-tech-function/c 21 | (->* () 22 | (#:key (or/c string? #f) #:normalize? boolean?) 23 | #:rest (listof pre-content?) 24 | element?)) 25 | 26 | (define ((cross-document-tech-function doc) 27 | #:key [key #f] #:normalize? [normalize? #t] . text) 28 | (apply tech 29 | #:doc doc 30 | #:key key 31 | #:normalize? normalize? 32 | text)) 33 | 34 | (define reference-tech 35 | (cross-document-tech-function 36 | '(lib "scribblings/reference/reference.scrbl"))) 37 | 38 | (define rebellion-tech 39 | (cross-document-tech-function '(lib "rebellion/main.scrbl")))) 40 | -------------------------------------------------------------------------------- /private/scribble-evaluator-factory.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module doc racket/base 4 | 5 | (require racket/contract/base) 6 | 7 | (provide 8 | (contract-out 9 | [make-module-sharing-evaluator-factory 10 | (->* () 11 | (#:private (listof module-path?) 12 | #:public (listof module-path?)) 13 | (-> (-> any/c any)))])) 14 | 15 | (require rebellion/collection/list 16 | scribble/example) 17 | 18 | ;@---------------------------------------------------------------------------- 19 | 20 | (define (make-module-sharing-evaluator-factory 21 | #:public [public-modules empty-list] 22 | #:private [private-modules empty-list]) 23 | (define base-factory 24 | (make-base-eval-factory (append private-modules public-modules))) 25 | (λ () 26 | (define evaluator (base-factory)) 27 | (evaluator `(require ,@public-modules)) 28 | evaluator))) 29 | -------------------------------------------------------------------------------- /traversal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [traversal? predicate/c] 8 | [traversal/c (-> contract? contract? contract?)] 9 | [make-traversal 10 | (->* (#:getter (-> any/c immutable-vector?) 11 | #:setter (-> any/c immutable-vector? any/c) 12 | #:counter (-> any/c natural?)) 13 | (#:name (or/c interned-symbol? #f)) 14 | traversal?)] 15 | [traversal-count (-> traversal? any/c natural?)] 16 | [traversal-get-all (-> traversal? any/c immutable-vector?)] 17 | [traversal-set-all (-> traversal? any/c (sequence/c any/c) any/c)] 18 | [traversal-pipe (-> traversal? ... traversal?)] 19 | [subtraversal 20 | (->i ([traversal traversal?] 21 | [inclusive-start natural?]) 22 | ([exclusive-end 23 | (inclusive-start) 24 | (or/c (and/c natural? (>=/c inclusive-start)) #f)]) 25 | [_ traversal?])] 26 | [list-traversal (traversal/c list? any/c)] 27 | [vector-traversal (traversal/c vector? any/c)] 28 | [string-traversal (traversal/c string? char?)] 29 | [identity-traversal traversal?] 30 | [lens->traversal (-> lens? traversal?)] 31 | [prism->traversal (-> prism? traversal?)] 32 | [traversal-map (-> traversal? any/c (-> any/c any/c) any/c)] 33 | [traversal-clear (-> traversal? any/c any/c any/c)] 34 | [traversal-reverse (-> traversal? any/c any/c)])) 35 | 36 | (require glass/lens 37 | glass/prism 38 | racket/bool 39 | racket/contract/combinator 40 | racket/match 41 | racket/math 42 | racket/sequence 43 | racket/vector 44 | rebellion/base/immutable-string 45 | rebellion/base/option 46 | rebellion/base/symbol 47 | rebellion/collection/vector 48 | rebellion/collection/immutable-vector 49 | rebellion/collection/list 50 | rebellion/private/contract-projection 51 | rebellion/private/impersonation 52 | rebellion/private/static-name 53 | rebellion/streaming/reducer 54 | rebellion/streaming/transducer 55 | rebellion/type/object 56 | rebellion/type/tuple) 57 | 58 | (module+ test 59 | (require (submod "..") 60 | rackunit 61 | rebellion/base/pair 62 | rebellion/base/result)) 63 | 64 | ;@------------------------------------------------------------------------------ 65 | 66 | (define-object-type traversal (getter setter counter) 67 | #:constructor-name constructor:traversal) 68 | 69 | (define (make-traversal 70 | #:getter getter 71 | #:setter setter 72 | #:counter [counter (λ (s) (immutable-vector-length (getter s)))] 73 | #:name [name #f]) 74 | (constructor:traversal 75 | #:getter (function-reduce-arity getter 1) 76 | #:setter (function-reduce-arity setter 2) 77 | #:counter (function-reduce-arity counter 1) 78 | #:name name)) 79 | 80 | (define (function-reduce-arity function expected-arity) 81 | (if (equal? (procedure-arity function) expected-arity) 82 | function 83 | (procedure-reduce-arity function expected-arity))) 84 | 85 | (define (traversal-count traversal subject) 86 | ((traversal-counter traversal) subject)) 87 | 88 | (define (traversal-get-all traversal subject) 89 | ((traversal-getter traversal) subject)) 90 | 91 | (define/name (traversal-set-all traversal subject foci) 92 | (define original-count (traversal-count traversal subject)) 93 | (define foci-vec (sequence->vector foci)) 94 | (define replacement-count (immutable-vector-length foci-vec)) 95 | (unless (equal? replacement-count original-count) 96 | (raise-arguments-error 97 | enclosing-function-name 98 | "traversals cannot be used to change the number of traversed elements" 99 | "traversal" traversal 100 | "original count" original-count 101 | "replacement count" replacement-count 102 | "subject" subject)) 103 | ((traversal-setter traversal) subject foci-vec)) 104 | 105 | (define/name list-traversal 106 | (make-traversal 107 | #:getter sequence->vector 108 | #:setter (λ (_ replacements) (immutable-vector->list replacements)) 109 | #:counter list-size 110 | #:name enclosing-variable-name)) 111 | 112 | (define/name vector-traversal 113 | (make-traversal 114 | #:getter vector->immutable-vector 115 | #:setter (λ (_ replacements) replacements) 116 | #:counter vector-length 117 | #:name enclosing-variable-name)) 118 | 119 | (define/name string-traversal 120 | (make-traversal 121 | #:getter sequence->vector 122 | #:setter 123 | (λ (_ replacements) 124 | (build-immutable-string 125 | (immutable-vector-length replacements) 126 | (λ (i) (vector-ref replacements i)))) 127 | #:counter string-length 128 | #:name enclosing-variable-name)) 129 | 130 | (module+ test 131 | (test-case (name-string traversal-set-all) 132 | (define (set-too-many) 133 | (traversal-set-all 134 | list-traversal (list 1 2 3) (immutable-vector 4 5 6 7 8))) 135 | (check-exn exn:fail:contract? set-too-many) 136 | (check-exn #rx"traversal-set-all" set-too-many) 137 | (check-exn #rx"original count: 3" set-too-many) 138 | (check-exn #rx"replacement count: 5" set-too-many)) 139 | 140 | (test-case (name-string list-traversal) 141 | (check-equal? (traversal-count list-traversal (list 1 2 3)) 3) 142 | (check-equal? 143 | (traversal-get-all list-traversal (list 1 2 3)) (immutable-vector 1 2 3)) 144 | (check-equal? 145 | (traversal-set-all list-traversal (list 1 2 3) (immutable-vector 4 5 6)) 146 | (list 4 5 6))) 147 | 148 | (test-case (name-string vector-traversal) 149 | (check-equal? (traversal-count vector-traversal (vector 1 2 3)) 3) 150 | (check-equal? (traversal-count vector-traversal (immutable-vector 1 2 3)) 3) 151 | (check-equal? 152 | (traversal-get-all vector-traversal (vector 1 2 3)) 153 | (immutable-vector 1 2 3)) 154 | (check-equal? 155 | (traversal-get-all vector-traversal (immutable-vector 1 2 3)) 156 | (immutable-vector 1 2 3)) 157 | (define vec (vector 1 2 3)) 158 | (define result-vec 159 | (traversal-set-all vector-traversal vec (immutable-vector 4 5 6))) 160 | (check-equal? vec (vector 1 2 3)) 161 | (check-not-equal? result-vec vec) 162 | (check-pred immutable? result-vec) 163 | (check-equal? result-vec (immutable-vector 4 5 6))) 164 | 165 | (test-case (name-string string-traversal) 166 | (check-equal? (traversal-count string-traversal "hello") 5) 167 | (check-equal? (traversal-count string-traversal (string #\a #\b #\c)) 3) 168 | (check-equal? 169 | (traversal-get-all string-traversal "hello") 170 | (immutable-vector #\h #\e #\l #\l #\o)) 171 | (check-equal? 172 | (traversal-get-all string-traversal (string #\a #\b #\c)) 173 | (immutable-vector #\a #\b #\c)) 174 | (define str (string #\a #\b #\c)) 175 | (define result-str (traversal-set-all string-traversal str "foo")) 176 | (check-equal? str "abc") 177 | (check-not-equal? result-str str) 178 | (check-pred immutable? result-str) 179 | (check-equal? result-str "foo"))) 180 | 181 | ;@------------------------------------------------------------------------------ 182 | ;; Contracts 183 | 184 | (define (traversal-impersonate 185 | traversal 186 | #:subject-input-guard [subject-input-guard #f] 187 | #:subject-output-guard [subject-output-guard #f] 188 | #:foci-input-guard [foci-input-guard #f] 189 | #:foci-output-guard [foci-output-guard #f] 190 | #:properties [properties (hash)] 191 | #:count-marks [count-marks (hash)] 192 | #:get-marks [get-marks (hash)] 193 | #:set-marks [set-marks (hash)] 194 | #:chaperone? 195 | [chaperone? 196 | (nor subject-input-guard 197 | subject-output-guard 198 | foci-input-guard 199 | foci-output-guard)]) 200 | (define counter (traversal-counter traversal)) 201 | (define getter (traversal-getter traversal)) 202 | (define setter (traversal-setter traversal)) 203 | (define chaperoned-counter 204 | (function-impersonate counter #:application-marks count-marks)) 205 | (define impersonated-getter 206 | (function-impersonate 207 | getter 208 | #:arguments-guard subject-input-guard 209 | #:results-guard (λ (foci) (immutable-vector-map foci-output-guard foci)) 210 | #:application-marks get-marks 211 | #:chaperone? chaperone?)) 212 | (define impersonated-setter 213 | (function-impersonate 214 | setter 215 | #:arguments-guard 216 | (λ (subject replacement-foci) 217 | (values (subject-input-guard subject) 218 | (immutable-vector-map foci-input-guard replacement-foci))) 219 | #:results-guard subject-output-guard 220 | #:application-marks set-marks 221 | #:chaperone? chaperone?)) 222 | (define impersonated-without-props 223 | (make-traversal 224 | #:getter impersonated-getter 225 | #:setter impersonated-setter 226 | #:counter chaperoned-counter 227 | #:name (object-name traversal))) 228 | (object-impersonate 229 | impersonated-without-props descriptor:traversal 230 | #:properties properties)) 231 | 232 | (define/name (traversal/c subject-contract* foci-contract*) 233 | (define subject-contract 234 | (coerce-contract enclosing-function-name subject-contract*)) 235 | (define foci-contract 236 | (coerce-contract enclosing-function-name foci-contract*)) 237 | (define contract-name 238 | (build-compound-type-name 239 | enclosing-function-name subject-contract foci-contract)) 240 | (define subject-projection (contract-late-neg-projection subject-contract)) 241 | (define foci-projection (contract-late-neg-projection foci-contract)) 242 | (define chaperone? 243 | (and (chaperone-contract? subject-contract) 244 | (chaperone-contract? foci-contract))) 245 | (define (projection blame) 246 | (define subject-input-blame 247 | (blame-add-context 248 | blame "an input traversal subject of" #:swap? #t)) 249 | (define subject-output-blame 250 | (blame-add-context blame "an output traversal subject of")) 251 | (define foci-output-blame 252 | (blame-add-context blame "an output traversal focus of")) 253 | (define foci-input-blame 254 | (blame-add-context blame "an input traversal focus of" #:swap? #t)) 255 | (define late-neg-subject-input-guard 256 | (subject-projection subject-input-blame)) 257 | (define late-neg-foci-output-guard (foci-projection foci-output-blame)) 258 | (define late-neg-foci-input-guard (foci-projection foci-input-blame)) 259 | (define late-neg-subject-output-guard 260 | (subject-projection subject-output-blame)) 261 | (λ (original-traversal missing-party) 262 | (assert-satisfies 263 | original-traversal traversal? blame #:missing-party missing-party) 264 | (define props 265 | (hash impersonator-prop:contracted the-contract 266 | impersonator-prop:blame (cons blame missing-party))) 267 | (define (subject-input-guard input) 268 | (late-neg-subject-input-guard input missing-party)) 269 | (define (subject-output-guard output) 270 | (late-neg-subject-output-guard output missing-party)) 271 | (define (foci-input-guard input) 272 | (late-neg-foci-input-guard input missing-party)) 273 | (define (foci-output-guard output) 274 | (late-neg-foci-output-guard output missing-party)) 275 | (traversal-impersonate 276 | original-traversal 277 | #:subject-input-guard subject-input-guard 278 | #:subject-output-guard subject-output-guard 279 | #:foci-input-guard foci-input-guard 280 | #:foci-output-guard foci-output-guard 281 | #:chaperone? chaperone? 282 | #:properties props))) 283 | (define the-contract 284 | ((if chaperone? make-chaperone-contract make-contract) 285 | #:name contract-name 286 | #:first-order traversal? 287 | #:late-neg-projection projection)) 288 | the-contract) 289 | 290 | ;@------------------------------------------------------------------------------ 291 | ;; More traversals 292 | 293 | (define/name identity-traversal 294 | (make-traversal 295 | #:getter immutable-vector 296 | #:setter (λ (_ replacements) (immutable-vector-ref replacements 0)) 297 | #:counter (λ (_) 1) 298 | #:name enclosing-variable-name)) 299 | 300 | (define (traversal-pipe-getter outer-traversal inner-traversal) 301 | (define outer-getter (traversal-getter outer-traversal)) 302 | (define inner-getter (traversal-getter inner-traversal)) 303 | (λ (subject) 304 | (transduce (outer-getter subject) 305 | (append-mapping inner-getter) 306 | #:into (into-vector)))) 307 | 308 | (define-tuple-type setter-state (index traversed-subject)) 309 | (define initial-state (setter-state 0 #f)) 310 | 311 | (define (traversal-pipe-setter outer-traversal inner-traversal) 312 | (define outer-getter (traversal-getter outer-traversal)) 313 | (define outer-setter (traversal-setter outer-traversal)) 314 | (define inner-setter (traversal-setter inner-traversal)) 315 | (define inner-counter (traversal-counter inner-traversal)) 316 | (λ (subject replacements) 317 | (define outer-originals (outer-getter subject)) 318 | (define outer-replacements 319 | (transduce 320 | outer-originals 321 | (folding 322 | (λ (state inner-subject) 323 | (define count (inner-counter inner-subject)) 324 | (define previous-index (setter-state-index state)) 325 | (define next-index (+ previous-index count)) 326 | (define inner-replacements 327 | (subvector replacements previous-index next-index)) 328 | (define traversed (inner-setter inner-subject inner-replacements)) 329 | (setter-state next-index traversed)) 330 | initial-state) 331 | (mapping setter-state-traversed-subject) 332 | #:into (into-vector #:size (vector-length outer-originals)))) 333 | (outer-setter subject outer-replacements))) 334 | 335 | (define (traversal-pipe-counter outer-traversal inner-traversal) 336 | (define outer-getter (traversal-getter outer-traversal)) 337 | (define inner-counter (traversal-counter inner-traversal)) 338 | (λ (subject) 339 | (transduce (outer-getter subject) (mapping inner-counter) #:into into-sum))) 340 | 341 | (define (traversal-pipe2 outer-traversal inner-traversal) 342 | (define getter (traversal-pipe-getter outer-traversal inner-traversal)) 343 | (define setter (traversal-pipe-setter outer-traversal inner-traversal)) 344 | (define counter (traversal-pipe-counter outer-traversal inner-traversal)) 345 | (make-traversal 346 | #:getter getter #:setter setter #:counter counter #:name 'piped)) 347 | 348 | (define (traversal-pipe . traversales) 349 | (match traversales 350 | ['() identity-traversal] 351 | [(list traversal) traversal] 352 | [(cons first-traversal remaining-traversales) 353 | (for/fold ([piped first-traversal]) ([traversal remaining-traversales]) 354 | (traversal-pipe2 piped traversal))])) 355 | 356 | (define (subvector vector start [end #f]) 357 | (define actual-end (or end (immutable-vector-length vector))) 358 | (immutable-vector-copy vector start actual-end)) 359 | 360 | (module+ test 361 | (test-case (name-string traversal-pipe) 362 | 363 | (test-case "no traversals" 364 | (check-equal? (traversal-pipe) identity-traversal)) 365 | 366 | (test-case "one traversal" 367 | (check-equal? (traversal-pipe string-traversal) string-traversal)) 368 | 369 | (test-case "two traversals" 370 | (define string-list-traversal 371 | (traversal-pipe list-traversal string-traversal)) 372 | (define fruits (list "apple" "coconut" "plum")) 373 | (check-equal? 374 | (traversal-get-all string-list-traversal fruits) 375 | (immutable-vector 376 | #\a #\p #\p #\l #\e #\c #\o #\c #\o #\n #\u #\t #\p #\l #\u #\m)) 377 | (check-equal? 378 | (traversal-set-all string-list-traversal fruits "AppleCoconutPlum") 379 | (list "Apple" "Coconut" "Plum"))))) 380 | 381 | 382 | (define/name (subtraversal traversal start [end #f]) 383 | (define getter (traversal-getter traversal)) 384 | (define setter (traversal-setter traversal)) 385 | (define (get-all subject) (subvector (getter subject) start end)) 386 | (define (set-all subject subreplacements) 387 | (define originals (getter subject)) 388 | (define mutable-replacements (vector-copy originals)) 389 | (vector-copy! mutable-replacements start subreplacements) 390 | (setter subject (vector->immutable-vector mutable-replacements))) 391 | (make-traversal 392 | #:getter get-all #:setter set-all #:name enclosing-function-name)) 393 | 394 | (module+ test 395 | (test-case (name-string subtraversal) 396 | (define traversal (subtraversal string-traversal 2 6)) 397 | (check-equal? 398 | (traversal-map traversal "abracadabra" char-upcase) "abRACAdabra"))) 399 | 400 | 401 | (define (lens->traversal lens) 402 | (define (get-all subject) (immutable-vector (lens-get lens subject))) 403 | (define (set-all subject replacements) 404 | (lens-set lens subject (vector-ref replacements 0))) 405 | (make-traversal 406 | #:getter get-all 407 | #:setter set-all 408 | #:counter (λ (_) 1) 409 | #:name (object-name lens))) 410 | 411 | (define (prism->traversal prism) 412 | (define (get-all subject) 413 | (match (prism-match prism subject) 414 | [(present focus) (immutable-vector focus)] 415 | [(== absent) empty-immutable-vector])) 416 | (define (set-all subject replacements) 417 | (match (prism-match prism subject) 418 | [(? present?) (prism-cast prism (vector-ref replacements 0))] 419 | [(== absent) subject])) 420 | (define (count subject) 421 | (match (prism-match prism subject) [(? present?) 1] [(== absent) 0])) 422 | (make-traversal 423 | #:getter get-all 424 | #:setter set-all 425 | #:counter count 426 | #:name (object-name prism))) 427 | 428 | (module+ test 429 | (test-case (name-string lens->traversal) 430 | (define traversal (lens->traversal pair.first)) 431 | (check-equal? (traversal-get-all traversal (pair 1 2)) (immutable-vector 1)) 432 | (check-equal? 433 | (traversal-set-all traversal (pair 1 2) (immutable-vector 5)) (pair 5 2)) 434 | (check-equal? (traversal-count traversal (pair 1 2)) 1) 435 | (check-equal? (object-name traversal) (name pair.first))) 436 | 437 | (test-case (name-string prism->traversal) 438 | (define traversal (prism->traversal success-prism)) 439 | (check-equal? 440 | (traversal-get-all traversal (success 123)) (immutable-vector 123)) 441 | (check-equal? 442 | (traversal-get-all traversal (failure "foo")) empty-immutable-vector) 443 | (check-equal? 444 | (traversal-set-all traversal (success 123) (immutable-vector 5)) 445 | (success 5)) 446 | (check-equal? 447 | (traversal-set-all traversal (failure "foo") empty-immutable-vector) 448 | (failure "foo")) 449 | (check-equal? (traversal-count traversal (success 123)) 1) 450 | (check-equal? (traversal-count traversal (failure "foo")) 0) 451 | (check-equal? (object-name traversal) (name success-prism)))) 452 | 453 | 454 | (define (traversal-map traversal subject mapper) 455 | (define originals (traversal-get-all traversal subject)) 456 | (define replacements 457 | (transduce originals 458 | (mapping mapper) 459 | #:into (into-vector #:size (vector-length originals)))) 460 | (traversal-set-all traversal subject replacements)) 461 | 462 | (define (traversal-clear traversal subject replacement) 463 | (define count (traversal-count traversal subject)) 464 | (define replacements (make-immutable-vector count replacement)) 465 | (traversal-set-all traversal subject replacements)) 466 | 467 | (define in-descending-range 468 | (case-lambda 469 | [(end) (in-range (sub1 end) -1 -1)] 470 | [(start end) (in-range (sub1 end) (sub1 start) -1)])) 471 | 472 | (module+ test 473 | (test-case (name-string in-descending-range) 474 | (check-equal? (sequence->list (in-descending-range 4)) (list 3 2 1 0)) 475 | (check-equal? (sequence->list (in-descending-range 3 8)) (list 7 6 5 4 3)))) 476 | 477 | (define (traversal-reverse traversal subject) 478 | (define originals (traversal-get-all traversal subject)) 479 | (define count (vector-length originals)) 480 | (define reversed 481 | (for/vector #:length count ([i (in-descending-range count)]) 482 | (vector-ref originals i))) 483 | (traversal-set-all traversal subject reversed)) 484 | 485 | (module+ test 486 | (test-case (name-string traversal-map) 487 | (check-equal? (traversal-map string-traversal "foo" char-upcase) "FOO")) 488 | 489 | (test-case (name-string traversal-clear) 490 | (check-equal? (traversal-clear string-traversal "foo" #\x) "xxx")) 491 | 492 | (test-case (name-string traversal-reverse) 493 | (check-equal? (traversal-reverse string-traversal "hello") "olleh"))) 494 | -------------------------------------------------------------------------------- /traversal.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label glass/lens 4 | glass/prism 5 | glass/traversal 6 | racket/base 7 | racket/contract/base 8 | racket/list 9 | racket/math 10 | racket/sequence 11 | rebellion/base/result 12 | rebellion/base/symbol 13 | rebellion/collection/entry 14 | rebellion/collection/immutable-vector 15 | rebellion/collection/list 16 | rebellion/type/tuple) 17 | (submod glass/private/scribble-cross-document-tech doc) 18 | (submod glass/private/scribble-evaluator-factory doc) 19 | scribble/example) 20 | 21 | @(define make-evaluator 22 | (make-module-sharing-evaluator-factory 23 | #:public (list 'glass/lens 24 | 'glass/prism 25 | 'glass/traversal 26 | 'racket/list 27 | 'rebellion/base/result 28 | 'rebellion/collection/entry 29 | 'rebellion/collection/immutable-vector 30 | 'rebellion/type/tuple) 31 | #:private (list 'racket/base))) 32 | 33 | @title{Traversals} 34 | @defmodule[glass/traversal] 35 | 36 | A @deftech{traversal} is a type of @tech{optic} for focusing on several parts of 37 | a subject at once. A traversal is built from a getter function, which extracts a 38 | list of foci from the subject, and a setter function, which takes a subject and 39 | a list of replacement foci and builds a new subject. Traversals are not allowed 40 | to change the number of foci when replacing them: if a traversal's getter views 41 | 10 foci in a subject, then the traversal's setter will only accept lists of 42 | exactly 10 replacement foci. 43 | 44 | @defproc[(traversal? [v any/c]) boolean?]{ 45 | A predicate for @tech{traversals}.} 46 | 47 | @defproc[(make-traversal 48 | [#:getter getter (-> any/c immutable-vector?)] 49 | [#:setter setter (-> any/c immutable-vector? any/c)] 50 | [#:counter counter (-> any/c natural?) 51 | (λ (suject) (immutable-vector-length (getter subject)))] 52 | [#:name name (or/c interned-symbol? #f) #f]) 53 | traversal?]{ 54 | Constructs a @tech{traversal} named @racket[name]. 55 | 56 | @(examples 57 | #:eval (make-evaluator) #:once 58 | (eval:no-prompt 59 | (define-tuple-type player (name x y)) 60 | (define player-coordinates 61 | (make-traversal 62 | #:getter (λ (p) (immutable-vector (player-x p) (player-y p))) 63 | #:setter 64 | (λ (p xy) (player (player-name p) (vector-ref xy 0) (vector-ref xy 1))) 65 | #:counter (λ (_) 2) 66 | #:name 'player-coordinates))) 67 | (traversal-get-all player-coordinates (player "Catherine" 2 7)) 68 | (traversal-set-all player-coordinates (player "Catherine" 2 7) (list 0 0)))} 69 | 70 | @defproc[(traversal/c [subject-contract contract?] [foci-contract contract?]) 71 | contract?]{ 72 | A @reference-tech{contract combinator} for @tech{traversals}. Creates a 73 | contract that accepts traversals whose subjects are checked with 74 | @racket[subject-contract] and whose foci are checked with 75 | @racket[foci-contract].} 76 | 77 | @section{Using Traversals} 78 | 79 | @defproc[(traversal-get-all [traversal traversal?] [subject any/c]) 80 | immutable-vector?]{ 81 | Traverses @racket[subject] with @racket[traversal] and returns a list of the 82 | traversal's foci.} 83 | 84 | @defproc[(traversal-set-all 85 | [traversal traversal?] [subject any/c] [foci (sequence/c any/c)]) 86 | any/c]{ 87 | Traverses @racket[subject] with @racket[traversal] and replaces each focus with 88 | an element of @racket[foci], returning a new subject. If @racket[foci] does not 89 | contain the same number of elements as the traversed subject, a contract error 90 | is raised.} 91 | 92 | @defproc[(traversal-count [traversal traversal?] [subject any/c]) natural?]{ 93 | Traverses @racket[subject] with @racket[traversal] and counts the traversal's 94 | foci.} 95 | 96 | @defproc[(traversal-map 97 | [traversal traversal?] [subject any/c] [mapper (-> any/c any/c)]) 98 | any/c]{ 99 | Traverses @racket[subject] with @racket[traversal] and updates each focus with 100 | @racket[mapper], returning a new subject with the updated foci. 101 | 102 | @(examples 103 | #:eval (make-evaluator) #:once 104 | (traversal-map string-traversal "hello" char-upcase))} 105 | 106 | @defproc[(traversal-clear 107 | [traversal traversal?] [subject any/c] [replacement any/c]) 108 | any/c]{ 109 | Traverses @racket[subject] with @racket[traversal] and sets each focus to 110 | @racket[replacement], returning a new subject with the updated foci. 111 | 112 | @(examples 113 | #:eval (make-evaluator) #:once 114 | (traversal-clear string-traversal "hello" #\x))} 115 | 116 | @defproc[(traversal-reverse [traversal traversal?] [subject any/c]) any/c]{ 117 | Traverses @racket[subject] with @racket[traversal] and reverses the order of 118 | the traversed foci, returning a new subject with the reversed foci. 119 | 120 | @(examples 121 | #:eval (make-evaluator) #:once 122 | (traversal-reverse string-traversal "hello"))} 123 | 124 | @section{Predefined Traversals} 125 | 126 | @defthing[list-traversal (traversal/c list? any/c)]{ 127 | A @tech{traversal} that traverses the elements of a list.} 128 | 129 | @defthing[vector-traversal (traversal/c vector? any/c)]{ 130 | A @tech{traversal} that traverses the elements of a vector. The traversal 131 | accepts both mutable and immutable vectors, but it only produces immutable 132 | vectors.} 133 | 134 | @defthing[string-traversal (traversal/c string? char?)]{ 135 | A @tech{traversal} that traverses the characters of a string. The traversal 136 | accepts both mutable and immutable strings, but it only produces immutable 137 | strings. 138 | 139 | @(examples 140 | #:eval (make-evaluator) #:once 141 | (traversal-count string-traversal "hello") 142 | (traversal-get-all string-traversal "hello"))} 143 | 144 | @defthing[identity-traversal traversal?]{ 145 | The identity @tech{traversal}. Traverses only one element of the subject, and 146 | that element is the subject itself. 147 | 148 | @(examples 149 | #:eval (make-evaluator) #:once 150 | (traversal-get-all identity-traversal 6) 151 | (traversal-set-all identity-traversal 6 (list 100)))} 152 | 153 | @section{More Traversal Constructors} 154 | 155 | @defproc[(traversal-pipe [traversal traversal?] ...) traversal?]{ 156 | Joins each @racket[traversal] to the next, building a composed traversal that 157 | traverses subjects by traversing the subject with the first traversal, then 158 | traversing each of those traversed elements with the second traversal, and so 159 | on for each traversal in left-to-right order. If only one @racket[traversal] is 160 | given, it is returned directly. If no traversals are given, 161 | @racket[identity-traversal] is returned. 162 | 163 | @(examples 164 | #:eval (make-evaluator) #:once 165 | (eval:no-prompt 166 | (define list-of-strings-traversal 167 | (traversal-pipe list-traversal string-traversal)) 168 | (define strings (list "hello" "darkness" "my" "old" "friend"))) 169 | (traversal-map list-of-strings-traversal strings char-upcase) 170 | (traversal-clear list-of-strings-traversal strings #\-) 171 | (traversal-reverse list-of-strings-traversal strings))} 172 | 173 | @defproc[(subtraversal 174 | [traversal traversal?] 175 | [inclusive-start natural?] 176 | [exclusive-end (or/c natural? #f) #f]) 177 | traversal?]{ 178 | Limits @racket[traversal] to only operate on the elements between 179 | @racket[inclusive-start] and @racket[exclusive-end]. If @racket[exclusive-end] 180 | is false, the subtraversal includes all elements after 181 | @racket[inclusive-start]. 182 | 183 | @(examples 184 | #:eval (make-evaluator) #:once 185 | (traversal-clear (subtraversal string-traversal 2 8) "hello world" #\_))} 186 | 187 | @defproc[(lens->traversal [lens lens?]) traversal?]{ 188 | Converts @racket[lens] into a @tech{traversal} that always focuses on exactly 189 | one part of the subject using @racket[lens]. 190 | 191 | @(examples 192 | #:eval (make-evaluator) #:once 193 | (define entry.key-traversal (lens->traversal entry.key)) 194 | (traversal-get-all entry.key-traversal (entry 'grapes 4)) 195 | (traversal-set-all entry.key-traversal (entry 'grapes 4) (list 'apples)))} 196 | 197 | @defproc[(prism->traversal [prism prism?]) traversal?]{ 198 | Converts @racket[prism] into a @tech{traversal} that has either zero foci, if 199 | @racket[prism] does not match the subject, or one focus if @racket[prism] does 200 | match the subject. 201 | 202 | @(examples 203 | #:eval (make-evaluator) #:once 204 | (define success-traversal (prism->traversal success-prism)) 205 | (traversal-get-all success-traversal (success 5)) 206 | (traversal-set-all success-traversal (success 5) (list 10)))} 207 | --------------------------------------------------------------------------------