blob: ea2be9611db359e801e1b0cbad52038be1dee6b7 (
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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
(import (algebraic-structures functor)
(algebraic-structures applicative)
(algebraic-structures monad))
(module (data optional) (<some> some some? some-value <none> none none?)
(import scheme
(chicken base)
(chicken format))
(define-record-type <some>
(some value)
some?
(value some-value))
(set! (record-printer <some>)
(lambda (x out)
(fprintf out "#<(some ~S)>" (some-value x))))
(define-record-type <none>
(none)
none?)
(set! (record-printer <none>)
(lambda (_ out)
(fprintf out "#<(none)>"))))
(module (data optional functor) = (algebraic-structures functor)
(import scheme
(prefix (data optional) opt:)
matchable
(chicken module))
(export map1)
(define (map1 f opt)
(match opt
[($ opt:<some> x) (opt:some (f x))]
[($ opt:<none>) (opt:none)])))
(module (data optional applicative) = (algebraic-structures applicative)
(import scheme
(prefix (data optional) opt:)
matchable
(chicken module))
(reexport (data optional functor))
(export pure map2)
(define (pure x)
(opt:some x))
(define (map2 f opt1 opt2)
(match opt1
[($ opt:<some> x)
(match opt2
[($ opt:<some> y) (opt:some (f x y))]
[($ opt:<none>) (opt:none)])]
[($ opt:<none>) (opt:none)])))
(module (data optional monad) = (algebraic-structures monad)
(import (except scheme map apply)
(prefix (data optional) opt:)
matchable
(chicken module))
(reexport (data optional applicative))
(export >>=)
(define (>>= opt f)
(match opt
[($ opt:<some> x) (f x)]
[($ opt:<none>) (opt:none)])))
(import (prefix (data optional) opt:))
(import (prefix (data optional applicative) opt:))
(import (prefix (data optional monad) opt:))
;; (opt:map (lambda (x) (* x x)) (opt:pure 5)) => (some 25)
;; (opt:map (lambda (x) (* x x)) (opt:none)) => (none)
;; (opt:map + (opt:pure 1) (opt:pure 2) (opt:pure 3)) => (some 6)
;; (opt:map + (opt:pure 1) (opt:none) (opt:pure 3)) => (none)
;; (opt:do (x <- (opt:pure 3))
;; (y <- (opt:pure 4))
;; (opt:pure (+ x y)))
;; => (some 7)
|
