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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
open Preface_core.Fun
type ('a, 'b) t = ('a, 'b) result =
| Ok of 'a
| Error of 'b
let pure x = Ok x
module Bifunctor = Preface_make.Bifunctor.Via_bimap (struct
type nonrec ('a, 'b) t = ('a, 'b) t
let bimap f g = function Ok x -> Ok (f x) | Error x -> Error (g x)
end)
module Functor = Preface_make.Indexed_functor.Via_map (struct
type nonrec ('a, 'b) t = ('a, 'b) t
let map f x = Bifunctor.bimap f id x
end)
module Alt =
Preface_make.Indexed_alt.Over_functor
(Functor)
(struct
type nonrec ('a, 'b) t = ('a, 'b) t
let combine x y = match (x, y) with Error _, a -> a | a, _ -> a
end)
module Applicative = Preface_make.Indexed_applicative.Via_pure_and_apply (struct
type nonrec ('a, 'b) t = ('a, 'b) t
let pure = pure
let apply fa xa =
match (fa, xa) with Ok f, x -> Functor.map f x | Error x, _ -> Error x
;;
end)
module Monad = Preface_make.Indexed_monad.Via_return_and_bind (struct
type nonrec ('a, 'b) t = ('a, 'b) t
let return = pure
let bind f = function Ok x -> f x | Error x -> Error x
end)
module Selective =
Preface_make.Indexed_selective.Over_applicative_via_select
(Applicative)
(Preface_make.Indexed_selective.Select_from_monad (Monad))
module Foldable = Preface_make.Indexed_foldable.Via_fold_right (struct
type nonrec ('a, 'b) t = ('a, 'b) t
let fold_right f x acc = match x with Error _ -> acc | Ok v -> f v acc
end)
module Mono (T : Preface_specs.Types.T0) = struct
module Functor = Preface_make.Functor.Via_map (struct
type nonrec 'a t = ('a, T.t) t
let map f x = Bifunctor.bimap f id x
end)
module Invariant = Preface_make.Invariant.From_functor (Functor)
module Alt =
Preface_make.Alt.Over_functor
(Functor)
(struct
type nonrec 'a t = ('a, T.t) t
let combine x y = match (x, y) with Error _, a -> a | a, _ -> a
end)
let traverse_aux pure map f = function
| Error x -> pure (Error x)
| Ok x -> map (fun x -> Ok x) (f x)
;;
module Applicative = struct
module A = Preface_make.Applicative.Via_pure_and_apply (struct
module F = Functor
type nonrec 'a t = ('a, T.t) t
let pure = pure
let apply fa xa =
match (fa, xa) with Ok f, x -> F.map f x | Error x, _ -> Error x
;;
end)
module T (A : Preface_specs.APPLICATIVE) =
Preface_make.Traversable.Over_applicative
(A)
(struct
type 'a t = 'a A.t
type 'a iter = ('a, T.t) Bifunctor.t
let traverse f x = traverse_aux A.pure A.map f x
end)
include Preface_make.Traversable.Join_with_applicative (A) (T)
end
module Monad = struct
module M = Preface_make.Monad.Via_return_and_bind (struct
type nonrec 'a t = ('a, T.t) t
let return = pure
let bind f = function Ok x -> f x | Error x -> Error x
end)
module T (M : Preface_specs.MONAD) =
Preface_make.Traversable.Over_monad
(M)
(struct
type 'a t = 'a M.t
type 'a iter = ('a, T.t) Bifunctor.t
let traverse f x = traverse_aux M.return M.map f x
end)
include Preface_make.Traversable.Join_with_monad (M) (T)
end
module Selective =
Preface_make.Selective.Over_applicative_via_select
(Applicative)
(Preface_make.Selective.Select_from_monad (Monad))
module Foldable = Preface_make.Foldable.Via_fold_right (struct
type nonrec 'a t = ('a, T.t) t
let fold_right f x acc = match x with Error _ -> acc | Ok v -> f v acc
end)
end
let equal f g left right =
match (left, right) with
| Ok x, Ok y -> f x y
| Error x, Error y -> g x y
| _ -> false
;;
let pp f g formater = function
| Ok x -> Format.fprintf formater "Ok (%a)" f x
| Error x -> Format.fprintf formater "Error (%a)" g x
;;