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
36
37
38
39
40
41
|
(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))
(chicken base)
(only M pure map1 map2 map apply >>=))
(import-for-syntax matchable
(chicken syntax)
(only (srfi 1) every last))
(define-syntax do
(er-macro-transformer
(lambda (expr rename compare)
(match expr
[(_ body ...)
(foldr (lambda (binding acc)
(match binding
[(var stx expr)
(if (and (symbol? var)
(symbol? stx)
(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 'let)
(symbol? =-stx) (compare =-stx '=))
`((,(rename 'lambda) (,var) ,acc) ,expr))
((and (list? var)
(every symbol? var)
(symbol? let-stx) (compare let-stx 'let-values)
(symbol? =-stx) (compare =-stx '=))
`(,(rename 'receive) ,var ,expr ,acc))
(else
`(,(rename '>>=) ,binding (,(rename 'lambda) (_) ,acc))))]
[expr
`(,(rename '>>=) ,expr (,(rename 'lambda) (_) ,acc))]))
(last body)
(butlast body))])))))
|
