Source file Constant.ml
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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
open Signatures
open Combinators
type 'c r
external to_rea : 'c -> ('c r, 'e, 'a) s = "%identity"
external of_rea : ('c r, 'e, 'a) s -> 'c = "%identity"
let from x _ = to_rea x
let map d _ xC = to_rea (of_rea (xC d))
class ['c, 'D] functr =
object (d : 'D)
inherit ['c r, 'D] map'
method map' = map d
end
let functr =
object (d)
method map' : 'e 'a 'b. ('c r, 'e, 'a, 'b, 'D) map'm = map d
end
let pair_with d combine xC yC =
to_rea (combine (fun () -> of_rea (xC d)) (fun () -> of_rea (yC d)))
class ['c, 'D] product combine =
object (d : 'D)
inherit ['c, 'D] functr
inherit ['c r, 'D] pair'
method pair' = pair_with d combine
end
let pure_of x _ = to_rea x
class ['c, 'D] applicative identity combine =
object (_ : 'D)
inherit ['c, 'D] product combine
inherit ['c r, 'D] pure'
method pure' = pure_of identity
end
let conjunction = new applicative true @@ fun l r -> l () && r ()
let disjunction = new applicative false @@ fun l r -> l () || r ()
let option =
object (d : 'D)
method map' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) map'm = map d
method pure' : 'e 'a. (_, 'e, 'a, 'D) pure'm = pure_of None
method pair' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) pair'm =
pair_with d @@ fun l r -> match l () with None -> r () | s -> s
end
let unit_er =
object (d : 'D)
method map' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) map'm = map d
method pure' : 'e 'a. (_, 'e, 'a, 'D) pure'm = pure_of unit
method pair' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) pair'm =
pair_with d @@ fun l r -> l () >>= r
end
let false_er d = pure false d
let true_er d = pure true d
let disjunction_er =
object (d : 'D)
method map' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) map'm = map d
method pure' : 'e 'a. (_, 'e, 'a, 'D) pure'm = pure_of false_er
method pair' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) pair'm =
pair_with d @@ fun l r ->
l () >>= function true -> true_er | false -> r ()
end
let conjunction_er =
object (d : 'D)
method map' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) map'm = map d
method pure' : 'e 'a. (_, 'e, 'a, 'D) pure'm = pure_of true_er
method pair' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) pair'm =
pair_with d @@ fun l r ->
l () >>= function false -> false_er | true -> r ()
end
let none_er d = pure None d
let option_er =
object (d : 'D)
method map' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) map'm = map d
method pure' : 'e 'a. (_, 'e, 'a, 'D) pure'm = pure_of none_er
method pair' : 'e 'a 'b. (_, 'e, 'a, 'b, 'D) pair'm =
pair_with d @@ fun l r ->
l () >>= function None -> r () | some -> pure some
end