Source file arrow.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
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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
module Core_over_category_and_via_arrow_and_fst
(Category : Preface_specs.CATEGORY)
(Req : Preface_specs.Arrow.WITH_ARROW_AND_FST
with type ('a, 'b) t = ('a, 'b) Category.t) :
Preface_specs.Arrow.CORE with type ('a, 'b) t = ('a, 'b) Req.t = struct
include Category
include Req
let split pre post =
let open Infix in
let swap (x, y) = (y, x) in
fst pre >>> arrow swap >>> fst post >>> arrow swap
;;
end
module Core_over_category_and_via_arrow_and_split
(Category : Preface_specs.CATEGORY)
(Req : Preface_specs.Arrow.WITH_ARROW_AND_SPLIT
with type ('a, 'b) t = ('a, 'b) Category.t) :
Preface_specs.Arrow.CORE with type ('a, 'b) t = ('a, 'b) Req.t = struct
include Category
include Req
let fst x = split x id
end
module Operation_over_category
(Category : Preface_specs.CATEGORY)
(Core : Preface_specs.Arrow.CORE with type ('a, 'b) t = ('a, 'b) Category.t) :
Preface_specs.Arrow.OPERATION with type ('a, 'b) t = ('a, 'b) Core.t = struct
include Category
let return () = Core.arrow (fun x -> x)
let snd x = Core.split id x
let fan_out pre post =
Infix.(Core.arrow (fun x -> (x, x)) >>> Core.split pre post)
;;
let pre_compose_left_to_right f x = Infix.(Core.arrow f >>> x)
let post_compose_left_to_right x f = Infix.(x >>> Core.arrow f)
let pre_compose_right_to_left x f = Infix.(x <<< Core.arrow f)
let post_compose_right_to_left f x = Infix.(Core.arrow f <<< x)
end
module Alias (Operation : Preface_specs.Arrow.OPERATION) :
Preface_specs.Arrow.ALIAS with type ('a, 'b) t = ('a, 'b) Operation.t = struct
type ('a, 'b) t = ('a, 'b) Operation.t
let pre_compose f x = Operation.pre_compose_left_to_right f x
let post_compose x f = Operation.post_compose_left_to_right x f
end
module Infix_over_category
(Category : Preface_specs.CATEGORY)
(Core : Preface_specs.Arrow.CORE with type ('a, 'b) t = ('a, 'b) Category.t)
(Operation : Preface_specs.Arrow.OPERATION
with type ('a, 'b) t = ('a, 'b) Core.t) :
Preface_specs.Arrow.INFIX with type ('a, 'b) t = ('a, 'b) Operation.t = struct
include Category.Infix
let ( *** ) l r = Core.split l r
let ( &&& ) l r = Operation.fan_out l r
let ( ^>> ) l r = Operation.pre_compose_left_to_right l r
let ( >>^ ) l r = Operation.post_compose_left_to_right l r
let ( <<^ ) l r = Operation.pre_compose_right_to_left l r
let ( ^<< ) l r = Operation.post_compose_right_to_left l r
end
module Via
(Core : Preface_specs.Arrow.CORE)
(Operation : Preface_specs.Arrow.OPERATION
with type ('a, 'b) t = ('a, 'b) Core.t)
(Alias : Preface_specs.Arrow.ALIAS
with type ('a, 'b) t = ('a, 'b) Operation.t)
(Infix : Preface_specs.Arrow.INFIX with type ('a, 'b) t = ('a, 'b) Alias.t) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Infix.t = struct
include Core
include Operation
include Alias
include Infix
module Infix = Infix
end
module Over_category_and_via_arrow_and_fst
(Category : Preface_specs.CATEGORY)
(Req : Preface_specs.Arrow.WITH_ARROW_AND_FST
with type ('a, 'b) t = ('a, 'b) Category.t) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Req.t = struct
module Core = Core_over_category_and_via_arrow_and_fst (Category) (Req)
module Operation = Operation_over_category (Category) (Core)
module Alias = Alias (Operation)
module Infix = Infix_over_category (Category) (Core) (Operation)
include Core
include Operation
include Alias
include Infix
end
module Over_category_and_via_arrow_an_split
(Category : Preface_specs.CATEGORY)
(Req : Preface_specs.Arrow.WITH_ARROW_AND_SPLIT
with type ('a, 'b) t = ('a, 'b) Category.t) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Req.t = struct
module Core = Core_over_category_and_via_arrow_and_split (Category) (Req)
module Operation = Operation_over_category (Category) (Core)
module Alias = Alias (Operation)
module Infix = Infix_over_category (Category) (Core) (Operation)
include Core
include Operation
include Alias
include Infix
end
module From_monad (Monad : Preface_specs.Monad.CORE) :
Preface_specs.ARROW with type ('a, 'b) t = 'a -> 'b Monad.t = struct
module Cat = Category.From_monad (Monad)
module Arr = struct
type ('a, 'b) t = 'a -> 'b Monad.t
let arrow f = (fun f g x -> f (g x)) Monad.return f
let fst f (b, d) = Monad.bind (fun c -> Monad.return (c, d)) (f b)
end
include Over_category_and_via_arrow_and_fst (Cat) (Arr)
end
module From_arrow_plus (Plus : Preface_specs.ARROW_PLUS) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Plus.t =
Plus
module From_arrow_alt (Alt : Preface_specs.ARROW_ALT) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Alt.t =
Alt
module From_arrow_zero (Zero : Preface_specs.ARROW_ZERO) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Zero.t =
Zero
module From_arrow_choice (Choice : Preface_specs.ARROW_CHOICE) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Choice.t =
Choice
module From_arrow_apply (Apply : Preface_specs.ARROW_APPLY) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Apply.t =
Apply
module From_strong_and_category
(Strong : Preface_specs.Strong.WITH_DIMAP_AND_FST)
(Category : Preface_specs.CATEGORY with type ('a, 'b) t = ('a, 'b) Strong.t) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) Category.t =
Over_category_and_via_arrow_and_fst
(Category)
(struct
type ('a, 'b) t = ('a, 'b) Category.t
let arrow f = Strong.dimap f (fun x -> x) Category.id
let fst = Strong.fst
end)
module Product (F : Preface_specs.ARROW) (G : Preface_specs.ARROW) :
Preface_specs.ARROW with type ('a, 'b) t = ('a, 'b) F.t * ('a, 'b) G.t =
Over_category_and_via_arrow_and_fst
(Category.Product (F) (G))
(struct
type ('a, 'b) t = ('a, 'b) F.t * ('a, 'b) G.t
let arrow f = (F.arrow f, G.arrow f)
let fst (x, y) = (F.fst x, G.fst y)
end)