blob: 2594a74d525ef052feca553c5704944d66e5337a (
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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
(import (algebraic-structures functor)
(algebraic-structures applicative)
(algebraic-structures monad))
(module (data state) (run get put)
(import (except scheme map)
(only (chicken base) void assert)
matchable)
(define (run m init)
(car (m init)))
(define get
(lambda (st)
(cons st st)))
(define (put st)
(lambda (_st)
(cons (void) st))))
(module (data state functor) = (algebraic-structures functor)
(import scheme
matchable
(chicken module))
(export map1)
(define (map1 f m)
(lambda (st)
(match-let ([(x . st*) (m st)])
(cons (f x) st*)))))
(module (data state applicative) = (algebraic-structures applicative)
(import scheme
matchable
(chicken module))
(reexport (data state functor))
(export pure map2)
(define (pure x)
(lambda (st) (cons x st)))
(define (map2 f m1 m2)
(lambda (st)
(match-let* ([(x . st*) (m1 st)]
[(y . st**) (m2 st*)])
(cons (f x y) st**)))))
(module (data state monad) = (algebraic-structures monad)
(import (except scheme map apply)
matchable
(chicken module))
(reexport (data state applicative))
(export >>=)
(define (>>= m f)
(lambda (st)
(match-let* ([(x . st*) (m st)]
[(x* . st**) ((f x) st*)])
(cons x* st**)))))
(import (prefix (data state) st:)
(prefix (data state monad) st:))
;; (st:run (st:do (x <- st:get)
;; (let y = (* x 3))
;; (st:put y)
;; (z <- st:get)
;; (st:pure z))
;; 5)
;; => 15
|
