blob: 80bde364c35971d8dc1159ef56221c9ae1c0ce95 (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
(functor ((algebraic-structures monad) (M (pure map1 map2 map apply >>=)))
(pure map1 map2 map apply >>= do)
(import (rename scheme
(apply scheme:apply)
(map scheme:map)
(do scheme:do))
M)
(import-for-syntax matchable
(chicken syntax)
(only (srfi 1) last))
(define-syntax do
(ir-macro-transformer
(lambda (expr inject compare)
(match expr
[(_ body ...)
(foldr (lambda (binding acc)
(match binding
[(var stx expr)
(if (and (symbol? var)
(symbol? stx)
(compare stx '<-))
`(>>= ,expr (lambda (,var) ,acc))
`(>>= ,binding (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))
(else
`(>>= ,binding (lambda (_) ,acc))))]
[expr
`(>>= ,expr (lambda (_) ,acc))]))
(last body)
(butlast body))])))))
|