├── .gitignore ├── LICENSE ├── README.md ├── examples ├── calculator.scm └── parser.scm ├── lib ├── monads.scm └── monads │ ├── aux-keyword.scm │ ├── failure.scm │ ├── gen-id.scm │ ├── maybe.scm │ ├── parser.scm │ ├── receive.scm │ ├── record-contexts.scm │ └── syntax.scm ├── package.scm └── test ├── test-calculator.scm ├── test-maybe.scm └── test-parser.scm /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | *~ 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 | R6RS monads 2 | =========== 3 | 4 | This package implements genereric syntax for working with monads in R6RS scheme. 5 | 6 | Main syntax 7 | ----------- 8 | 9 | Given a monad `m` with chain operator `m->>=` and return operator `m-return`, we 10 | can define syntax: 11 | 12 | ```scheme 13 | (define-monad m m->>= m-return) 14 | ``` 15 | 16 | This defines two new pieces of syntax: `with-m` and `seq-m`. The first bundles 17 | the monadic operators in a context: 18 | 19 | ```scheme 20 | (with-m 21 | (>>= value (lambda (x) (return (* x 42))))) 22 | ``` 23 | 24 | The `seq-m` operator provides a syntax very similar to Haskell's `do`. 25 | 26 | ```scheme 27 | (seq-m 28 | (x <- (div 1 a)) 29 | (y <- (+ x 1)) 30 | (return y)) 31 | ``` 32 | 33 | Example: making a parser 34 | ------------------------ 35 | 36 | In this example we show how to build a very simple parser using the parser (state) 37 | monad in this libary. I learned how to build a monadic parser from Graham Hutton's 38 | book "Programming in Haskell". This is also explained in [Function pearls - Monadic 39 | parsing in Haskell](http://eprints.nottingham.ac.uk/223/1/pearl.pdf) by Graham Hutton 40 | and Eric Meijer. 41 | 42 | The `parser` monad is defined in `(monads parser)`. 43 | 44 | ```scheme 45 | (import (rnrs (6)) 46 | (monads) 47 | (monads parser)) 48 | ``` 49 | 50 | A value in the parser monad (or just 'parser') is a function that takes a state 51 | and returns `values` with a result and a new state. 52 | 53 | In this case, our state variable is a list. We will take elements from this 54 | list one by one. Our first parser is the function `element`. It takes an 55 | element from a list and returns it along with the rest of the list. 56 | If the list was empty, we return `*failure*`. 57 | 58 | ```scheme 59 | (define (element c) 60 | (if (null? c) 61 | (values *failure* c) 62 | (values (car c) (cdr c)))) 63 | ``` 64 | 65 | We can build a slightly more advanced parser, that filters the output of 66 | `element`. 67 | 68 | ```scheme 69 | (define (satisfies pred?) 70 | (seq-parser 71 | (x <- element) 72 | (if (pred? x) 73 | (return x) 74 | parser-failure))) 75 | ``` 76 | 77 | Note that, since the values in the parser monad are functions, `seq-parser` 78 | returns a function similar to `element`: one that takes a state and returns 79 | a value and a new state. 80 | 81 | Using `satisfies` we can build a parser that accepts only values that are 82 | `eq?` to a given value. 83 | 84 | ```scheme 85 | (define (equals x) 86 | (satisfies (lambda (y) (eq? x y)))) 87 | ``` 88 | 89 | Using these basic building blocks we can build a very simple parser that 90 | reads a recursive list structure. 91 | 92 | ```scheme 93 | (define number 94 | (satisfies number?)) 95 | 96 | (define list-of-items 97 | (seq-parser 98 | (x <- (equals '<)) 99 | (y <- (many item)) 100 | (z <- (equals '>)) 101 | (return y))) 102 | 103 | (define item 104 | (choice number list-of-items)) 105 | ``` 106 | 107 | Running this on a small test: 108 | 109 | ```scheme 110 | #| Test the code on a sample |# 111 | (let ((input '(< 1 2 < 3 4 > < < 5 > 6 > 7 >))) 112 | (display (parse list-of-items input)) 113 | (newline)) 114 | ``` 115 | 116 | gives the output 117 | 118 | ```scheme 119 | (1 2 (3 4) ((5) 6) 7) 120 | ``` 121 | 122 | ### Running this example 123 | This example can be found in the `examples` folder, and run with Guile 124 | 125 | ```bash 126 | guile -L lib examples/parser.scm 127 | ``` 128 | 129 | or with Chez Scheme 130 | 131 | ```bash 132 | scheme --libdirs lib --script examples/parser.scm 133 | ``` 134 | -------------------------------------------------------------------------------- /examples/calculator.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (monads) 3 | (monads receive) 4 | (monads record-contexts) 5 | (monads parser)) 6 | 7 | #| Reader should mimic functional file IO |# 8 | (define-record-context reader 9 | (fields text pos)) 10 | 11 | (define (reader-forward r) 12 | (with-reader r 13 | (make-reader text (+ 1 pos)))) 14 | 15 | (define (reader-peek r) 16 | (with-reader r 17 | (string-ref text pos))) 18 | 19 | (define (reader-end? r) 20 | (with-reader r 21 | (>= pos (string-length text)))) 22 | 23 | 24 | #| Read a character |# 25 | (define (item r) 26 | (if (reader-end? r) 27 | (values *failure* r) 28 | (values (reader-peek r) (reader-forward r)))) 29 | 30 | #| Read a character that satisfies pred |# 31 | (define (sat pred) 32 | (seq-parser 33 | (c <- item) 34 | (if (pred c) 35 | (return c) 36 | parser-failure))) 37 | 38 | #| Read a character equal to `c` |# 39 | (define (is-char c) 40 | (sat (lambda (x) (char=? x c)))) 41 | 42 | #| Read a sequence of characters identical to those in `lst` |# 43 | (define (is-list lst) 44 | (if (null? lst) 45 | (seq-parser (return '())) 46 | (seq-parser 47 | (is-char (car lst)) 48 | (is-list (cdr lst)) 49 | (return lst)))) 50 | 51 | #| Read a string identical to `s` |# 52 | (define (is-string s) 53 | (seq-parser 54 | (u <- (is-list (string->list s))) 55 | (return (list->string u)))) 56 | 57 | #| Read a sequence of items `p` separated by `sep`. |# 58 | (define (sep-by p sep) 59 | (define (sep-by* p sep) 60 | (seq-parser 61 | (a <- p) 62 | (as <- (many (seq-parser sep p))) 63 | (return (cons a as)))) 64 | 65 | (choice sep-by* parser-failure)) 66 | 67 | #| Read `p`, then read `op`, `p`, fold-left on the result 68 | | of applying the result of `op`. 69 | |# 70 | (define chain-left 71 | (case-lambda 72 | ((value operator) 73 | (define (rest a) 74 | (choice (seq-parser 75 | (f <- operator) 76 | (b <- value) 77 | (rest (f a b))) 78 | (with-parser (return a)))) 79 | (seq-parser (a <- value) (rest a))) 80 | 81 | ((value operator alternative) 82 | (with-parser 83 | (choice (chain-left value operator) 84 | (return alternative)))))) 85 | 86 | #| Read many spaces |# 87 | (define space (many (is-char #\space))) 88 | 89 | #| Tokenize parser |# 90 | (define (token p) 91 | (seq-parser 92 | (a <- p) space (return a))) 93 | 94 | #| Read a tokenized string |# 95 | (define (symb cs) 96 | (token (is-string cs))) 97 | 98 | #| Apply parser, return only result |# 99 | (define (parse p r) 100 | (receive (result forget-r) ((seq-parser space p) r) 101 | result)) 102 | 103 | #| Parse an integer |# 104 | (define number 105 | (seq-parser 106 | (x <- (token (some (sat char-numeric?)))) 107 | (return (string->number (list->string x))))) 108 | 109 | (define addop 110 | (choice 111 | (seq-parser 112 | (symb "+") (return +)) 113 | (seq-parser 114 | (symb "-") (return -)))) 115 | 116 | (define mulop 117 | (choice 118 | (seq-parser 119 | (symb "*") (return *)) 120 | (seq-parser 121 | (symb "/") (return /)))) 122 | 123 | #| For these last three definitions, order of definition matters. 124 | | The original in Haskell is lazy. 125 | |# 126 | (define factor 127 | (choice number 128 | (seq-parser 129 | (symb "(") 130 | (n <- expr) 131 | (symb ")") 132 | (return n)))) 133 | 134 | (define term (chain-left factor mulop)) 135 | 136 | (define expr (chain-left term addop)) 137 | 138 | (define (calculate s) 139 | (display s) (display " = ") 140 | (display (parse expr (make-reader s 0))) 141 | (newline)) 142 | 143 | (calculate " 1 - 2 * 3 + 4") 144 | (calculate "3 * 42 / (6*7 - 3)") 145 | -------------------------------------------------------------------------------- /examples/parser.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (monads) 3 | (monads parser)) 4 | 5 | #| Get an item from input list |# 6 | (define (element c) 7 | (if (null? c) 8 | (values *failure* c) 9 | (values (car c) (cdr c)))) 10 | 11 | #| Get an item from input that satisfies `pred?` |# 12 | (define (satisfies pred?) 13 | (seq-parser 14 | (x <- element) 15 | (if (pred? x) 16 | (return x) 17 | parser-failure))) 18 | 19 | #| Get an item from input that equals `x` |# 20 | (define (equals x) 21 | (satisfies (lambda (y) (eq? x y)))) 22 | 23 | #| Get a |# 24 | (define number 25 | (satisfies number?)) 26 | 27 | #| Get a : many s |# 28 | (define list-of-items 29 | (seq-parser 30 | (x <- (equals '<)) 31 | (y <- (many item)) 32 | (z <- (equals '>)) 33 | (return y))) 34 | 35 | #| Get an : or |# 36 | (define item 37 | (choice number list-of-items)) 38 | 39 | (let ((input '(< 1 2 < 3 4 > < < 5 > 6 > 7 >))) 40 | (display (parse list-of-items input)) 41 | (newline)) 42 | -------------------------------------------------------------------------------- /lib/monads.scm: -------------------------------------------------------------------------------- 1 | (library (monads) 2 | 3 | (export 4 | ;;; syntax 5 | define-monad define-context <- 6 | 7 | ;;; failure 8 | failure? make-failure failure-trace failure-exception *failure*) 9 | 10 | (import (rnrs (6)) 11 | (monads failure) 12 | (monads syntax)) 13 | ) 14 | -------------------------------------------------------------------------------- /lib/monads/aux-keyword.scm: -------------------------------------------------------------------------------- 1 | #| Code snippet from Andy Keep |# 2 | (library (monads aux-keyword) 3 | (export define-auxiliary-keyword 4 | define-auxiliary-keywords) 5 | 6 | (import (rnrs (6))) 7 | 8 | (define-syntax define-auxiliary-keyword 9 | (syntax-rules () 10 | [(_ name) 11 | (define-syntax name 12 | (lambda (x) 13 | (syntax-violation #f "misplaced use of auxiliary keyword" x)))])) 14 | 15 | (define-syntax define-auxiliary-keywords 16 | (syntax-rules () 17 | [(_ name* ...) 18 | (begin (define-auxiliary-keyword name*) ...)])) 19 | ) 20 | -------------------------------------------------------------------------------- /lib/monads/failure.scm: -------------------------------------------------------------------------------- 1 | (library (monads failure) 2 | (export failure? make-failure failure-exception failure-trace *failure*) 3 | (import (rnrs (6))) 4 | 5 | #| Failure object 6 | |# 7 | (define-record-type failure 8 | (fields exception trace state) 9 | (protocol 10 | (lambda (new) 11 | (case-lambda 12 | (() (new #f #f #f)) 13 | ((e) (new e #f #f)) 14 | ((e t) (new e t #f)) 15 | ((e t s) (new e t s)))))) 16 | 17 | (define *failure* (make-failure)) 18 | ) 19 | -------------------------------------------------------------------------------- /lib/monads/gen-id.scm: -------------------------------------------------------------------------------- 1 | (library (monads gen-id) 2 | (export gen-id) 3 | (import (rnrs (6))) 4 | 5 | ; Define a new symbol, code from TSPL Chapter 8. 6 | (define gen-id 7 | (lambda (template-id . args) 8 | (datum->syntax template-id 9 | (string->symbol 10 | (apply string-append 11 | (map (lambda (x) 12 | (if (string? x) 13 | x 14 | (symbol->string (syntax->datum x)))) 15 | args)))))) 16 | ) 17 | -------------------------------------------------------------------------------- /lib/monads/maybe.scm: -------------------------------------------------------------------------------- 1 | (library (monads maybe) 2 | (export with-maybe seq-maybe) 3 | (import (rnrs (6)) 4 | (monads syntax) 5 | (monads failure)) 6 | 7 | (define (maybe->>= value f) 8 | (if (failure? value) 9 | value 10 | (f value))) 11 | 12 | (define maybe-return values) 13 | 14 | (define-monad maybe maybe->>= maybe-return) 15 | ) 16 | -------------------------------------------------------------------------------- /lib/monads/parser.scm: -------------------------------------------------------------------------------- 1 | (library (monads parser) 2 | (export with-parser seq-parser parser-failure 3 | parse choice some many) 4 | 5 | (import (rnrs (6)) 6 | (monads receive) 7 | (monads failure) 8 | (monads syntax)) 9 | 10 | #| ---------------------------------------------------------------- 11 | | Parser monad 12 | |# 13 | (define (parser-return value) 14 | (lambda (cursor) 15 | (values value cursor))) 16 | 17 | #| Returns *failed*, doesn't consume. 18 | |# 19 | (define (parser-failure cursor) 20 | (values *failure* cursor)) 21 | 22 | #| Chain operator 23 | |# 24 | (define (parser->>= parser f) 25 | (lambda (cursor) 26 | (receive (value next) (parser cursor) 27 | (if (failure? value) 28 | (values value next) 29 | ((f value) next))))) 30 | 31 | (define-monad parser parser->>= parser-return) 32 | 33 | #| Tries to parse with p1, if that fails, take p2. 34 | |# 35 | (define (choice2 p1 p2) 36 | (lambda (cur1) 37 | (receive (v cur2) (p1 cur1) 38 | (if (failure? v) 39 | (p2 cur1) 40 | (values v cur2))))) 41 | 42 | #| Tries to parse with p, if that fails, parses with (choice ps) 43 | |# 44 | (define (choice p . ps) 45 | (fold-left choice2 p ps)) 46 | 47 | #| Accepts any number of parsings with `p`. 48 | |# 49 | (define (many p) 50 | (with-parser 51 | (choice (some p) (return '())))) 52 | 53 | #| Accepts one or more parsings with `p`. 54 | |# 55 | (define (some p) 56 | (seq-parser 57 | (v <- p) 58 | (vs <- (many p)) 59 | (return (cons v vs)))) 60 | 61 | #| Applies input to parser p, then returns only the result. 62 | |# 63 | (define (parse p input) 64 | (receive (result _) (p input) 65 | result)) 66 | ) 67 | -------------------------------------------------------------------------------- /lib/monads/receive.scm: -------------------------------------------------------------------------------- 1 | (library (monads receive) 2 | (export receive) 3 | (import (rnrs (6))) 4 | 5 | ;;; (srfi :8 receive) 6 | (define-syntax receive 7 | (syntax-rules () 8 | ((_ ...) 9 | (call-with-values 10 | (lambda () ) 11 | (lambda ...))))) 12 | ) 13 | -------------------------------------------------------------------------------- /lib/monads/record-contexts.scm: -------------------------------------------------------------------------------- 1 | (library (monads record-contexts) 2 | (export define-record-context) 3 | (import (rnrs (6)) 4 | (monads gen-id)) 5 | 6 | (define-syntax define-record-context 7 | (lambda (x) 8 | (syntax-case x (fields) 9 | [(define-context (fields ...) ...) 10 | (with-syntax ([with-record (gen-id #' "with-" #')] 11 | [update-record (gen-id #' "update-" #')] 12 | [make-record (gen-id #' "make-" #')] 13 | ; Define the names of member access functions. 14 | [(access ...) (map (lambda (x) 15 | (gen-id x #' "-" x)) 16 | #'( ...))]) 17 | #'(begin 18 | (define-record-type (fields ...) ...) 19 | 20 | (define-syntax with-record 21 | (lambda (x) 22 | (syntax-case x () 23 | [(with-record (... ...)) 24 | (with-syntax ([ (datum->syntax #'with-record ')] 25 | ...) 26 | #'(let ([ (access )] ...) 27 | (... ...)))]))) 28 | 29 | (define-syntax update-record 30 | (lambda (x) 31 | (syntax-case x () 32 | [(update-record (... ...)) 33 | (with-syntax ([ (datum->syntax #'update-record ')] 34 | ...) 35 | #'(let ([ (access )] ...) 36 | (let ( (... ...)) 37 | (make-record ...))))]))) 38 | ))]))) 39 | ) 40 | -------------------------------------------------------------------------------- /lib/monads/syntax.scm: -------------------------------------------------------------------------------- 1 | (library (monads syntax) 2 | (export define-monad define-context <-) 3 | 4 | (import (rnrs (6)) 5 | ; (only (chezscheme) trace-define-syntax) 6 | (monads gen-id) 7 | (monads aux-keyword)) 8 | 9 | #| Defines a context; think of it as a persistent let-binding. 10 | | 11 | | (define-context ( ) ...) 12 | | 13 | | creates a new syntax `with-` that expands to 14 | | 15 | | (letrec (( ) ...) ) 16 | | 17 | | such that the variables ... are in scope of . 18 | |# 19 | (define-syntax define-context 20 | (lambda (x) 21 | (syntax-case x () 22 | ((define-context ( ) ...) 23 | (with-syntax (( (gen-id #' "with-" #'))) 24 | #'(define-syntax 25 | (lambda (x) 26 | (syntax-case x () 27 | (( <> (... ...)) 28 | (with-syntax (( (datum->syntax #' ')) 29 | ...) 30 | #'(letrec (( ) ...) 31 | <> (... ...))))))) 32 | ))))) 33 | 34 | #| Defines a context for the defined monad. In addition to the given 35 | | parameters for the chain and return operators, the sequence syntax is 36 | | defined. 37 | | 38 | | For a generic monad, this syntax looks like: 39 | | 40 | | (define-syntax seq 41 | | (syntax-rules (<-) 42 | | ;; last one get's out 43 | | ((seq foo) foo) 44 | | 45 | | ;; chain notation 46 | | ((seq (arg <- foo) rest ...) 47 | | (>>= foo (lambda (arg) (seq rest ...)))) 48 | | 49 | | ;; side-effects, result is not used 50 | | ((seq foo rest ...) 51 | | (>>= foo (lambda (_) (seq rest ...)))))) 52 | | 53 | | We use the contexts defined above to create specific syntax for each 54 | | defined monad. This means that, within the `seq` syntax, the operators 55 | | `>>=` and `return` work as expected. 56 | |# 57 | (define-syntax define-monad 58 | (lambda (x) 59 | (syntax-case x () 60 | ((define-monad ( ) ...) 61 | (with-syntax (( (gen-id #' "with-" #')) 62 | ( (gen-id #' "seq-" #'))) 63 | #'(begin 64 | (define-context 65 | (>>= ) 66 | (return ) 67 | ( ) ...) 68 | 69 | (define-syntax 70 | (lambda (y) 71 | (define (wrap ctx . body) 72 | (with-syntax (( (datum->syntax ctx '>>=)) 73 | ( (datum->syntax ctx 'return)) 74 | ( (datum->syntax ctx ')) 75 | ...) 76 | #`(letrec (( ) 77 | ( ) 78 | ( ) ...) 79 | #,@body))) 80 | 81 | (syntax-case y (<-) 82 | (( <>) 83 | (wrap #' #'<>)) 84 | 85 | (( (<> (... ...) <- <>) <> (... ...)) 86 | (wrap #' 87 | #'( 88 | <> (lambda (<> (... ...)) 89 | ( <> (... ...)))))) 90 | 91 | (( <> <> (... ...)) 92 | (wrap #' 93 | #'( 94 | <> (lambda _ 95 | ( <> (... ...)))))))))) 96 | ))))) 97 | 98 | (define-auxiliary-keyword <-) 99 | ) 100 | -------------------------------------------------------------------------------- /package.scm: -------------------------------------------------------------------------------- 1 | (package monads) 2 | (version (0 1 0)) 3 | (requires (rnrs (6))) 4 | 5 | (libdirs "lib") 6 | -------------------------------------------------------------------------------- /test/test-calculator.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (monads) 3 | (monads receive) 4 | (monads record-contexts) 5 | (monads parser)) 6 | 7 | #| Reader should mimic functional file IO |# 8 | (define-record-context reader 9 | (fields text pos)) 10 | 11 | (define (reader-forward r) 12 | (with-reader r 13 | (make-reader text (+ 1 pos)))) 14 | 15 | (define (reader-peek r) 16 | (with-reader r 17 | (string-ref text pos))) 18 | 19 | (define (reader-end? r) 20 | (with-reader r 21 | (>= pos (string-length text)))) 22 | 23 | 24 | #| Read a character |# 25 | (define (item r) 26 | (if (reader-end? r) 27 | (values *failure* r) 28 | (values (reader-peek r) (reader-forward r)))) 29 | 30 | #| Read a character that satisfies pred |# 31 | (define (sat pred) 32 | (seq-parser 33 | (c <- item) 34 | (if (pred c) 35 | (return c) 36 | parser-failure))) 37 | 38 | #| Read a character equal to `c` |# 39 | (define (is-char c) 40 | (sat (lambda (x) (char=? x c)))) 41 | 42 | #| Read a sequence of characters identical to those in `lst` |# 43 | (define (is-list lst) 44 | (if (null? lst) 45 | (seq-parser (return '())) 46 | (seq-parser 47 | (is-char (car lst)) 48 | (is-list (cdr lst)) 49 | (return lst)))) 50 | 51 | #| Read a string identical to `s` |# 52 | (define (is-string s) 53 | (seq-parser 54 | (u <- (is-list (string->list s))) 55 | (return (list->string u)))) 56 | 57 | #| Read a sequence of items `p` separated by `sep`. |# 58 | (define (sep-by p sep) 59 | (define (sep-by* p sep) 60 | (seq-parser 61 | (a <- p) 62 | (as <- (many (seq-parser sep p))) 63 | (return (cons a as)))) 64 | 65 | (choice sep-by* parser-failure)) 66 | 67 | #| Read `p`, then read `op`, `p`, fold-left on the result 68 | | of applying the result of `op`. 69 | |# 70 | (define chain-left 71 | (case-lambda 72 | ((value operator) 73 | (define (rest a) 74 | (choice (seq-parser 75 | (f <- operator) 76 | (b <- value) 77 | (rest (f a b))) 78 | (with-parser (return a)))) 79 | (seq-parser (a <- value) (rest a))) 80 | 81 | ((value operator alternative) 82 | (with-parser 83 | (choice (chain-left value operator) 84 | (return alternative)))))) 85 | 86 | #| Read many spaces |# 87 | (define space (many (is-char #\space))) 88 | 89 | #| Tokenize parser |# 90 | (define (token p) 91 | (seq-parser 92 | (a <- p) space (return a))) 93 | 94 | #| Read a tokenized string |# 95 | (define (symb cs) 96 | (token (is-string cs))) 97 | 98 | #| Apply parser, return only result |# 99 | (define (parse p r) 100 | (receive (result forget-r) ((seq-parser space p) r) 101 | result)) 102 | 103 | #| Parse an integer |# 104 | (define number 105 | (seq-parser 106 | (x <- (token (some (sat char-numeric?)))) 107 | (return (string->number (list->string x))))) 108 | 109 | (define addop 110 | (choice 111 | (seq-parser 112 | (symb "+") (return +)) 113 | (seq-parser 114 | (symb "-") (return -)))) 115 | 116 | (define mulop 117 | (choice 118 | (seq-parser 119 | (symb "*") (return *)) 120 | (seq-parser 121 | (symb "/") (return /)))) 122 | 123 | #| For these last three definitions, order of definition matters. 124 | | The original in Haskell is lazy. 125 | |# 126 | (define factor 127 | (choice number 128 | (seq-parser 129 | (symb "(") 130 | (n <- expr) 131 | (symb ")") 132 | (return n)))) 133 | 134 | (define term (chain-left factor mulop)) 135 | 136 | (define expr (chain-left term addop)) 137 | 138 | (define (calculate s) 139 | (parse expr (make-reader s 0))) 140 | 141 | (define (test-calculator) 142 | (assert (= -1 (calculate " 1 - 2 * 3 + 4"))) 143 | (assert (= 42/13 (calculate "3 * 42 / (6*7 - 3)")))) 144 | -------------------------------------------------------------------------------- /test/test-maybe.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (monads) 3 | (monads maybe)) 4 | 5 | (define (test-context) 6 | (define-context x (a 1) (b 2)) 7 | (with-x 8 | (assert (= a 1)) 9 | (assert (= b 2)))) 10 | 11 | (define (div x y) 12 | (if (= 0 y) 13 | *failure* 14 | (/ x y))) 15 | 16 | (define (test-with-maybe) 17 | (define (inc x) (+ 1 x)) 18 | (with-maybe 19 | (assert (failure? (>>= (div 1 0) inc))) 20 | (assert (= 3/2 (>>= (div 1 2) inc))) 21 | (assert (= 42 (return 42))))) 22 | 23 | (define (test-seq-maybe) 24 | (define (f x) 25 | (seq-maybe 26 | (a <- (div 1 x)) 27 | (b <- (+ a 1)) 28 | (return b))) 29 | 30 | (assert (failure? (f 0))) 31 | (assert (= 4/3 (f 3)))) 32 | -------------------------------------------------------------------------------- /test/test-parser.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (monads) 3 | (monads parser)) 4 | 5 | 6 | (define (item c) 7 | (if (null? c) 8 | (values *failure* c) 9 | (values (car c) (cdr c)))) 10 | 11 | 12 | (define (satisfies pred?) 13 | (seq-parser 14 | (x <- item) 15 | (if (pred? x) 16 | (return x) 17 | parser-failure))) 18 | 19 | 20 | (define (test-parsers) 21 | (let ((p (some (satisfies number?)))) 22 | (assert (failure? (parse p '(a b c)))) 23 | (assert (equal? '(1 2 3) (parse p '(1 2 3))))) 24 | 25 | (let ((p (many (seq-parser 26 | (x <- item) 27 | (y <- item) 28 | (return (cons y x)))))) 29 | (assert (equal? '((b . a) (d . c) (f . e)) 30 | (parse p '(a b c d e f)))))) 31 | 32 | 33 | (define (test-parser-recursion) 34 | (define (equals x) 35 | (satisfies (lambda (y) (eq? x y)))) 36 | 37 | (define number 38 | (satisfies number?)) 39 | 40 | (define list-of-items 41 | (seq-parser 42 | (x <- (equals '<)) 43 | (y <- (many item)) 44 | (z <- (equals '>)) 45 | (return y))) 46 | 47 | (define item 48 | (choice number list-of-items)) 49 | 50 | (let ((input '(< 1 2 < 3 4 > < < 5 > 6 > 7 >))) 51 | (assert (equal? '(1 2 (3 4) ((5) 6) 7) 52 | (parse list-of-items input))))) 53 | 54 | --------------------------------------------------------------------------------