blob: b1aedc6005043f74db7d72dfd05f62f223626cf7 (
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
|
(module (data state)
(run get put map pure map2 >>=)
(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)))
(define (map f m)
(lambda (st)
(match-let ([(x . st*) (m st)])
(cons (f x) st*))))
(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**))))
(define (>>= m f)
(lambda (st)
(match-let* ([(x . st*) (m st)]
[(x* . st**) ((f x) st*)])
(cons x* st**)))))
(import (only (algebraic-structures functor make))
(only (algebraic-structures applicative make))
(only (algebraic-structures monad make)))
(module (data state functor) = ((algebraic-structures functor make) (data state)))
(module (data state applicative) = ((algebraic-structures applicative make) (data state)))
(module (data state monad) = ((algebraic-structures monad make) (data state)))
(import (prefix (data state) st:)
(prefix (data state functor) st:)
(prefix (data state applicative) 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
|
