diff options
| author | Masaya Tojo <masaya@tojo.tokyo> | 2024-06-16 20:11:05 +0900 |
|---|---|---|
| committer | Masaya Tojo <masaya@tojo.tokyo> | 2024-06-16 20:11:05 +0900 |
| commit | 6464288c0518db387657a16082fe541c253c463a (patch) | |
| tree | 64af7847624f8193bbded22a9974aa66ccf79f7b | |
| parent | 4d9ea3d067325285dc68ad2daae1620518a2741c (diff) | |
Use er-macro-transformer to define `do` syntax
| -rw-r--r-- | algebraic-structures.monad.scm | 27 |
1 files changed, 13 insertions, 14 deletions
diff --git a/algebraic-structures.monad.scm b/algebraic-structures.monad.scm index 2a7f466..27cf0fb 100644 --- a/algebraic-structures.monad.scm +++ b/algebraic-structures.monad.scm @@ -11,8 +11,8 @@ (only (srfi 1) every last)) (define-syntax do - (ir-macro-transformer - (lambda (expr inject compare) + (er-macro-transformer + (lambda (expr rename compare) (match expr [(_ body ...) (foldr (lambda (binding acc) @@ -20,23 +20,22 @@ [(var stx expr) (if (and (symbol? var) (symbol? stx) - (compare stx '<-)) - `(>>= ,expr (lambda (,var) ,acc)) - `(>>= ,binding (lambda (_) ,acc)))] + (compare stx (rename '<-))) + `(,(rename '>>=) ,expr (,(rename 'lambda) (,var) ,acc)) + `(,(rename '>>=) ,binding (,(rename 'lambda) (_) ,acc)))] [(let-stx var =-stx expr) (cond ((and (symbol? var) - (symbol? let-stx) (compare let-stx (inject 'let)) - (symbol? =-stx) (compare =-stx (inject '=))) - `((lambda (,var) ,acc) ,expr)) + (symbol? let-stx) (compare let-stx 'let) + (symbol? =-stx) (compare =-stx '=)) + `((,(rename 'lambda) (,var) ,acc) ,expr)) ((and (list? var) (every symbol? var) - (symbol? let-stx) (compare let-stx (inject 'let-values)) - (symbol? =-stx) (compare =-stx (inject '=))) - `(receive ,var ,expr - ,acc)) + (symbol? let-stx) (compare let-stx 'let-values) + (symbol? =-stx) (compare =-stx '=)) + `(,(rename 'receive) ,var ,expr ,acc)) (else - `(>>= ,binding (lambda (_) ,acc))))] + `(,(rename '>>=) ,binding (,(rename 'lambda) (_) ,acc))))] [expr - `(>>= ,expr (lambda (_) ,acc))])) + `(,(rename '>>=) ,expr (,(rename 'lambda) (_) ,acc))])) (last body) (butlast body))]))))) |