blob: 06bf3cbab4899e423c6ee67379b7d6e10e33627f (
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
|
(functor ((algebraic-structures monad) (M (pure map1 map2 map apply >>=)))
(pure map1 map2 map apply >>= do)
(import (rename scheme (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))])))))
|
